Made DataPoint accessors public

Made DataPoint accessors public

module Data.TimeSeries
    ( DataPoint
    , Series
    , dataPoint
    -- * Constructors
    , empty
    , fromDataPoints
    , fromValues
    , series
    , mkIndex
    -- Data access
    , dpIndex
    , dpValue
    , head
    , index
    , last
    , slice
    , resolution
    , values
    -- Data operations
    , diff
    , integrate
    , filter
    , groupBy
    , length
    , rollingWindow
    , toDataPoints
    , zipWith
    ) where

import Prelude
import Data.Array as A
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), fromMaybe, fromJust)
import Data.TimeSeries.Time (Timestamp)
import Data.Tuple (Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

-- | Data point is a time indexed value
data DataPoint a = DP Timestamp a

-- | Data structure for holding Series.
data Series a = Series (Array Timestamp) (Array a)

instance eqDataPoint :: Eq a => Eq (DataPoint a) where
    eq (DP idx1 vs1) (DP idx2 vs2) = (eq idx1 idx2) && (eq vs1 vs2)

instance showSeries :: Show a => Show (Series a) where
    show (Series idx vs) = "{ index: " <> show idx <> "\n, values: " <> show vs <> "\n}"

instance eqSeries :: Eq a => Eq (Series a) where
    eq (Series idx1 vs1) (Series idx2 vs2) = (eq idx1 idx2) && (eq vs1 vs2)

instance functorSeries :: Functor Series where
    map f (Series idx vs) = Series idx (map f vs)

-- | Create data point
dataPoint :: ∀ a. Timestamp -> a -> DataPoint a
dataPoint i v = DP i v

-- | Get DataPoint index
dpIndex :: ∀ a. DataPoint a -> Timestamp
dpIndex (DP i _) = i

-- | Get DataPoint value
dpValue :: ∀ a. DataPoint a -> a
dpValue (DP _ v) = v

-- | Get Series index
index :: ∀ a. Series a -> Array Timestamp
index (Series idx _) = idx

-- | Get Series values
values :: ∀ a. Series a -> Array a
values (Series _ vs) = vs

--  | Create series from indexes and values
series :: ∀ a. Array Timestamp -> Array a -> Series a
series is vs = Series is vs

-- | Create an empty series
empty :: ∀ a. Series a
empty = series [] []

-- | Create series from DateTime and value.
fromDataPoints :: ∀ a. Array (DataPoint a) -> Series a
fromDataPoints xs = series (map dpIndex xs) (map dpValue xs)

-- | Conver to array of data points
toDataPoints :: ∀ a. Series a -> Array (DataPoint a)
toDataPoints (Series idx vs) = (\t -> dataPoint (fst t) (snd t)) <$> A.zip idx vs

-- | Create series from values.
-- | Index will be based on Timestamp starting from 0
fromValues :: ∀ a. Array a -> Series a
fromValues xs = series (mkIndex (A.length xs)) xs

-- | Create index starting from lowest date (bottom)
-- | In each step time is increased by 1 second
mkIndex :: Int -> Array Timestamp
mkIndex n = map (\x -> 1000.0 * (toNumber x)) (A.range 0 (n-1))

-- | Get series length.
length :: ∀ a. Series a -> Int
length (Series idx vs) = A.length idx

-- | Get first element if exists
head :: ∀ a. Series a -> Maybe (DataPoint a)
head (Series idx vs) = do
    i <- A.head idx
    v <- A.head vs
    pure $ dataPoint i v

-- | Get last element if exists
last :: ∀ a. Series a -> Maybe (DataPoint a)
last (Series idx vs) = do
    i <- A.last idx
    v <- A.last vs
    pure $ dataPoint i v

-- | Get distance between points in this series
resolution :: ∀ a. Series a -> Number
resolution (Series idx _) = if n1 < 1 then 0.0 else (x2-x1) / toNumber n1
    where
        x1 = fromMaybe 0.0 (A.head idx)
        x2 = fromMaybe 0.0 (A.last idx)
        n1 = (A.length idx) - 1

-- | Get subseries
slice :: ∀ a. Timestamp     -- ^ Start time (inclusive)
      -> Timestamp          -- ^ End time (inclusive)
      -> Series a           -- ^ Input series
      -> Series a           -- ^ Sliced Series
slice start end (Series idx vs) = series (A.slice i j idx) (A.slice i j vs)
    where
        n = A.length idx
        i = fromMaybe n $ A.findIndex (\x -> x >= start) idx
        j = fromMaybe n $ A.findLastIndex (\x -> x <= end) idx

-- | Filter a series, keeping the elements which satisfy a predicate function, creating a new series.
filter :: ∀ a. (a -> Boolean) -> Series a -> Series a
filter pred (Series idx vs) = series (fst tu) (snd tu)
    where
        -- zip
        xs1 = A.zip idx vs
        -- filter zipped
        xs2 = A.filter (\t -> pred (snd t)) xs1
        -- Unzip
        tu = A.unzip xs2

-- | Join 2 series using given function
-- | Series will be joinned on index. It means that both series need to have the same index entries
-- | If only 1 series contains given index then this item will be dropped
zipWith :: ∀ a b c. (a -> b -> c) -> Series a -> Series b -> Series c
zipWith f xs ys = fromDataPoints $ zipWith' f (toDataPoints xs) (toDataPoints ys)

-- Helper function which works on data points
zipWith' :: ∀ a b c. (a -> b -> c) -> Array (DataPoint a) -> Array (DataPoint b) -> Array (DataPoint c)
zipWith' f xs ys = snd $ A.foldl g (Tuple ys []) xs
    where
        g :: Tuple (Array (DataPoint b)) (Array (DataPoint c)) -> DataPoint a -> Tuple (Array (DataPoint b)) (Array (DataPoint c))
        g tu x = if A.null ys' then tu
                 else if (dpIndex y') > (dpIndex x) then Tuple ys' (snd tu)
                 else Tuple yt' (A.snoc (snd tu) (dataPoint (dpIndex x) (f (dpValue x) (dpValue y'))))
            where
                ys' = A.dropWhile (\y -> (dpIndex y) < (dpIndex x)) (fst tu)
                y' = unsafePartial $ fromJust $ A.head ys'
                yt' = unsafePartial $ fromJust $ A.tail ys'

-- | Apply function to the rolling window and create new Series
rollingWindow :: ∀ a b. Int -> (Array a -> b) -> Series a -> Series b
rollingWindow n agg (Series idx vs) = series idx2 $ rolling' (A.take n1 vs) agg (A.drop n1 vs)
    where
        n1 = n-1
        idx2 = A.drop n1 idx

rolling' :: ∀ a b. Array a -> (Array a -> b) -> Array a -> Array b
rolling' mu agg xs = (A.foldl f {wnd: mu, out: []} xs).out
    where
      f {wnd: ws, out: os} x = {wnd: wnd2, out: A.snoc os (agg wnd1)}
        where
            wnd1 = A.snoc ws x
            wnd2 = A.drop 1 wnd1

-- | Differentiate Series xt = xt - x(t-1)
diff :: ∀ a. Ring a => Series a -> Series a
diff (Series idx vs) = Series (A.drop 1 idx) vs2
    where
        vs2 = A.zipWith (-) (A.drop 1 vs) vs

-- | Integrate Series
integrate :: ∀ a. Ring a => Series a -> Series a
integrate (Series idx vs) = Series idx v2
    where
        v2 = snd (A.foldl f (Tuple zero []) vs)
        f (Tuple a os) x = Tuple (a+x) (A.snoc os (a+x))

-- | Group series datapoints. This will reduce series data points number by given n.
groupBy :: ∀ a b. Number    -- ^ Window size in milliseconds
        -> (Array a -> b)   -- ^ Function applied to group values
        -> Series a         -- ^ Input series
        -> Series b         -- ^ Grouped series
groupBy dt f xs = fromDataPoints $ groupBy' dt f (toDataPoints xs)

groupBy' :: ∀ a b. Number -> (Array a -> b) -> Array (DataPoint a) -> Array (DataPoint b)
groupBy' dt f xs = snd $ A.foldl g (Tuple [] []) xs
    where
        g :: Tuple (Array (DataPoint a)) (Array (DataPoint b)) -> DataPoint a -> Tuple (Array (DataPoint a)) (Array (DataPoint b))
        g (Tuple acc out) x = case A.uncons acc of
            Just {head: y, tail} -> if (dpIndex x) < (dpIndex y) + dt
                                    then Tuple (A.snoc acc x) out
                                    else Tuple [x] (A.snoc out (dataPoint (dpIndex y) (f' acc)))
            Nothing -> Tuple [x] out
        f' :: Array (DataPoint a) -> b
        f' ds = f $ map dpValue ds

module Data.TimeSeries
    ( DataPoint
    , Series
    , dataPoint
    -- * Constructors
    , empty
    , fromDataPoints
    , fromValues
    , series
    , mkIndex
    -- Data access
    , head
    , last
    , slice
    , resolution
    -- Data operations
    , diff
    , index
    , integrate
    , filter
    , groupBy
    , length
    , rollingWindow
    , toDataPoints
    , values
    , zipWith
    ) where

import Prelude
import Data.Array as A
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), fromMaybe, fromJust)
import Data.TimeSeries.Time (Timestamp)
import Data.Tuple (Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

-- | Data point is a time indexed value
data DataPoint a = DP Timestamp a

-- | Data structure for holding Series.
data Series a = Series (Array Timestamp) (Array a)

instance eqDataPoint :: Eq a => Eq (DataPoint a) where
    eq (DP idx1 vs1) (DP idx2 vs2) = (eq idx1 idx2) && (eq vs1 vs2)

instance showSeries :: Show a => Show (Series a) where
    show (Series idx vs) = "{ index: " <> show idx <> "\n, values: " <> show vs <> "\n}"

instance eqSeries :: Eq a => Eq (Series a) where
    eq (Series idx1 vs1) (Series idx2 vs2) = (eq idx1 idx2) && (eq vs1 vs2)

instance functorSeries :: Functor Series where
    map f (Series idx vs) = Series idx (map f vs)

-- | Create data point
dataPoint :: ∀ a. Timestamp -> a -> DataPoint a
dataPoint i v = DP i v

-- | Get DataPoint index
dpIndex :: ∀ a. DataPoint a -> Timestamp
dpIndex (DP i _) = i

-- | Get DataPoint value
dpValue :: ∀ a. DataPoint a -> a
dpValue (DP _ v) = v

-- | Get Series index
index :: ∀ a. Series a -> Array Timestamp
index (Series idx _) = idx

-- | Get Series values
values :: ∀ a. Series a -> Array a
values (Series _ vs) = vs

--  | Create series from indexes and values
series :: ∀ a. Array Timestamp -> Array a -> Series a
series is vs = Series is vs

-- | Create an empty series
empty :: ∀ a. Series a
empty = series [] []

-- | Create series from DateTime and value.
fromDataPoints :: ∀ a. Array (DataPoint a) -> Series a
fromDataPoints xs = series (map dpIndex xs) (map dpValue xs)

-- | Conver to array of data points
toDataPoints :: ∀ a. Series a -> Array (DataPoint a)
toDataPoints (Series idx vs) = (\t -> dataPoint (fst t) (snd t)) <$> A.zip idx vs

-- | Create series from values.
-- | Index will be based on Timestamp starting from 0
fromValues :: ∀ a. Array a -> Series a
fromValues xs = series (mkIndex (A.length xs)) xs

-- | Create index starting from lowest date (bottom)
-- | In each step time is increased by 1 second
mkIndex :: Int -> Array Timestamp
mkIndex n = map (\x -> 1000.0 * (toNumber x)) (A.range 0 (n-1))

-- | Get series length.
length :: ∀ a. Series a -> Int
length (Series idx vs) = A.length idx

-- | Get first element if exists
head :: ∀ a. Series a -> Maybe (DataPoint a)
head (Series idx vs) = do
    i <- A.head idx
    v <- A.head vs
    pure $ dataPoint i v

-- | Get last element if exists
last :: ∀ a. Series a -> Maybe (DataPoint a)
last (Series idx vs) = do
    i <- A.last idx
    v <- A.last vs
    pure $ dataPoint i v

-- | Get distance between points in this series
resolution :: ∀ a. Series a -> Number
resolution (Series idx _) = if n1 < 1 then 0.0 else (x2-x1) / toNumber n1
    where
        x1 = fromMaybe 0.0 (A.head idx)
        x2 = fromMaybe 0.0 (A.last idx)
        n1 = (A.length idx) - 1

-- | Get subseries
slice :: ∀ a. Timestamp     -- ^ Start time (inclusive)
      -> Timestamp          -- ^ End time (inclusive)
      -> Series a           -- ^ Input series
      -> Series a           -- ^ Sliced Series
slice start end (Series idx vs) = series (A.slice i j idx) (A.slice i j vs)
    where
        n = A.length idx
        i = fromMaybe n $ A.findIndex (\x -> x >= start) idx
        j = fromMaybe n $ A.findLastIndex (\x -> x <= end) idx

-- | Filter a series, keeping the elements which satisfy a predicate function, creating a new series.
filter :: ∀ a. (a -> Boolean) -> Series a -> Series a
filter pred (Series idx vs) = series (fst tu) (snd tu)
    where
        -- zip
        xs1 = A.zip idx vs
        -- filter zipped
        xs2 = A.filter (\t -> pred (snd t)) xs1
        -- Unzip
        tu = A.unzip xs2

-- | Join 2 series using given function
-- | Series will be joinned on index. It means that both series need to have the same index entries
-- | If only 1 series contains given index then this item will be dropped
zipWith :: ∀ a b c. (a -> b -> c) -> Series a -> Series b -> Series c
zipWith f xs ys = fromDataPoints $ zipWith' f (toDataPoints xs) (toDataPoints ys)

-- Helper function which works on data points
zipWith' :: ∀ a b c. (a -> b -> c) -> Array (DataPoint a) -> Array (DataPoint b) -> Array (DataPoint c)
zipWith' f xs ys = snd $ A.foldl g (Tuple ys []) xs
    where
        g :: Tuple (Array (DataPoint b)) (Array (DataPoint c)) -> DataPoint a -> Tuple (Array (DataPoint b)) (Array (DataPoint c))
        g tu x = if A.null ys' then tu
                 else if (dpIndex y') > (dpIndex x) then Tuple ys' (snd tu)
                 else Tuple yt' (A.snoc (snd tu) (dataPoint (dpIndex x) (f (dpValue x) (dpValue y'))))
            where
                ys' = A.dropWhile (\y -> (dpIndex y) < (dpIndex x)) (fst tu)
                y' = unsafePartial $ fromJust $ A.head ys'
                yt' = unsafePartial $ fromJust $ A.tail ys'

-- | Apply function to the rolling window and create new Series
rollingWindow :: ∀ a b. Int -> (Array a -> b) -> Series a -> Series b
rollingWindow n agg (Series idx vs) = series idx2 $ rolling' (A.take n1 vs) agg (A.drop n1 vs)
    where
        n1 = n-1
        idx2 = A.drop n1 idx

rolling' :: ∀ a b. Array a -> (Array a -> b) -> Array a -> Array b
rolling' mu agg xs = (A.foldl f {wnd: mu, out: []} xs).out
    where
      f {wnd: ws, out: os} x = {wnd: wnd2, out: A.snoc os (agg wnd1)}
        where
            wnd1 = A.snoc ws x
            wnd2 = A.drop 1 wnd1

-- | Differentiate Series xt = xt - x(t-1)
diff :: ∀ a. Ring a => Series a -> Series a
diff (Series idx vs) = Series (A.drop 1 idx) vs2
    where
        vs2 = A.zipWith (-) (A.drop 1 vs) vs

-- | Integrate Series
integrate :: ∀ a. Ring a => Series a -> Series a
integrate (Series idx vs) = Series idx v2
    where
        v2 = snd (A.foldl f (Tuple zero []) vs)
        f (Tuple a os) x = Tuple (a+x) (A.snoc os (a+x))

-- | Group series datapoints. This will reduce series data points number by given n.
groupBy :: ∀ a b. Number    -- ^ Window size in milliseconds
        -> (Array a -> b)   -- ^ Function applied to group values
        -> Series a         -- ^ Input series
        -> Series b         -- ^ Grouped series
groupBy dt f xs = fromDataPoints $ groupBy' dt f (toDataPoints xs)

groupBy' :: ∀ a b. Number -> (Array a -> b) -> Array (DataPoint a) -> Array (DataPoint b)
groupBy' dt f xs = snd $ A.foldl g (Tuple [] []) xs
    where
        g :: Tuple (Array (DataPoint a)) (Array (DataPoint b)) -> DataPoint a -> Tuple (Array (DataPoint a)) (Array (DataPoint b))
        g (Tuple acc out) x = case A.uncons acc of
            Just {head: y, tail} -> if (dpIndex x) < (dpIndex y) + dt
                                    then Tuple (A.snoc acc x) out
                                    else Tuple [x] (A.snoc out (dataPoint (dpIndex y) (f' acc)))
            Nothing -> Tuple [x] out
        f' :: Array (DataPoint a) -> b
        f' ds = f $ map dpValue ds


add documentation to the Core module

add documentation to the Core module

-- | The Core module gathers types used across the library and provides basic Show instances for
-- | those types.
-- |
-- | NOTE:
-- | Errors normally thrown by the IDB* interfaces are wrapped in the `Aff` Monad as `Error`
-- | where the `message` corresponds to the error's name (e.g. "InvalidStateError").
-- | Pattern matching can therefore be done on any error message to handle specific errors thrown
-- | by the API.

module Database.IndexedDB.Core
  ( class FromString, parse
  , IDB
  , CursorDirection(..)
  , CursorSource(..)
  , Database
  , Index
  , KeyCursor
  , KeyRange
  , KeyPath
  , ObjectStore
  , Transaction
  , TransactionMode(..)
  , ValueCursor
  , module Database.IndexedDB.IDBKey
  ) where

import Prelude                     (class Show)

import Control.Monad.Eff           (kind Effect)
import Data.Maybe                  (Maybe(..))

import Database.IndexedDB.IDBKey

-- | IDB Effects, manifestation that something happened with the IndexedDB
foreign import data IDB :: Effect

-- | A cursor has a direction that determines whether it moves in monotonically
-- | increasing or decreasing order of the record keys when iterated, and if it
-- | skips duplicated values when iterating indexes.
-- | The direction of a cursor also determines if the cursor initial position is at
-- | the start of its source or at its end.
data CursorDirection
  = Next
  | NextUnique
  | Prev
  | PrevUnique

-- | If the source of a cursor is an object store, the effective object store of
-- | the cursor is that object store and the effective key of the cursor is the
-- | cursor’s position. If the source of a cursor is an index, the effective object
-- | store of the cursor is that index’s referenced object store and the effective key
-- | is the cursor’s object store position.
data CursorSource
  = ObjectStore ObjectStore
  | Index Index

-- | A transaction has a mode that determines which types of interactions can be performed
-- | upon that transaction. The mode is set when the transaction is created and remains
-- | fixed for the life of the transaction.
data TransactionMode
  = ReadOnly        -- ^ The transaction is only allowed to read data.
  | ReadWrite       -- ^ The transaction is allowed to read, modify and delete data from existing object stores
  | VersionChange   -- ^ The transaction is allowed to read, modify and delete data from existing object stores, and can also create and remove object stores and indexes.

-- | A key path is a list of strings that defines how to extract a key from a value.
-- | A valid key path is one of:
-- |
-- | - An empty list.
-- | - An singleton identifier, which is a string matching the IdentifierName production from the ECMAScript Language Specification [ECMA-262].
-- | - A singleton string consisting of two or more identifiers separated by periods (U+002E FULL STOP).
-- | - A non-empty list containing only strings conforming to the above requirements.
type KeyPath = Array String

-- | Each origin has an associated set of databases. A database has zero or more object
-- | stores which hold the data stored in the database.
foreign import data Database :: Type

-- | An index allows looking up records in an object store using properties of the values
-- | in the object stores records.
foreign import data Index :: Type

-- | A cursor is used to iterate over a range of records in an index or an object store
-- | in a specific direction. A KeyCursor doesn't hold any value.
foreign import data KeyCursor :: Type

-- | A key range is a continuous interval over some data type used for keys.
foreign import data KeyRange :: Type

-- | An object store is the primary storage mechanism for storing data in a database.
foreign import data ObjectStore :: Type

-- | A Transaction is used to interact with the data in a database.
-- | Whenever data is read or written to the database it is done by using a transaction.
foreign import data Transaction :: Type

-- | A cursor is used to iterate over a range of records in an index or an object store
-- | in a specific direction. A ValueCursor also holds the value corresponding to matching key.
foreign import data ValueCursor :: Type

-- | FromString represents enumerations that can be represented as Strings.
class FromString a where
  parse :: String -> Maybe a

foreign import _showCursor :: forall cursor. cursor -> String
instance showKeyCursor :: Show KeyCursor where
  show = _showCursor

instance showValueCursor :: Show ValueCursor where
  show = _showCursor

foreign import _showDatabase
  :: Database
  -> String
instance showDatabase :: Show Database where
  show = _showDatabase

foreign import _showIndex
  :: Index
  -> String
instance showIndex :: Show Index where
  show = _showIndex

foreign import _showKeyRange
  :: KeyRange
  -> String
instance showKeyRange :: Show KeyRange where
  show = _showKeyRange

foreign import _showObjectStore
  :: ObjectStore
  -> String
instance showObjectStore :: Show ObjectStore where
  show = _showObjectStore

foreign import _showTransaction
  :: Transaction
  -> String
instance showTransaction :: Show Transaction where
  show = _showTransaction

instance showCursorDirection :: Show CursorDirection where
  show x =
    case x of
      Next       -> "next"
      NextUnique -> "nextunique"
      Prev       -> "prev"
      PrevUnique -> "prevunique"

instance showTransactionMode :: Show TransactionMode where
  show x =
    case x of
      ReadOnly      -> "readonly"
      ReadWrite     -> "readwrite"
      VersionChange -> "versionchange"

instance fromStringCursorDirection :: FromString CursorDirection where
  parse s =
    case s of
      "next"       -> Just Next
      "nextunique" -> Just NextUnique
      "prev"       -> Just Prev
      "prevunique" -> Just PrevUnique
      _            -> Nothing

instance fromStringTransactionMode :: FromString TransactionMode where
  parse s =
    case s of
      "readonly"      -> Just ReadOnly
      "readwrite"     -> Just ReadWrite
      "versionchange" -> Just VersionChange
      _               -> Nothing

module Database.IndexedDB.Core
  ( class FromString, parse
  , IDB
  , CursorDirection(..)
  , CursorSource(..)
  , Database
  , Index
  , KeyCursor
  , KeyRange
  , KeyPath
  , ObjectStore
  , Transaction
  , TransactionMode(..)
  , ValueCursor
  , module Database.IndexedDB.IDBKey
  ) where

import Prelude                     (class Show)

import Control.Monad.Eff           (kind Effect)
import Data.Maybe                  (Maybe(..))

import Database.IndexedDB.IDBKey

foreign import data IDB :: Effect

data CursorDirection = Next | NextUnique | Prev | PrevUnique

data CursorSource = ObjectStore ObjectStore | Index Index

data TransactionMode = ReadOnly | ReadWrite | VersionChange

type KeyPath   = Array String

foreign import data Database :: Type

foreign import data Index :: Type

foreign import data KeyCursor :: Type

foreign import data KeyRange :: Type

foreign import data ObjectStore :: Type

foreign import data Transaction :: Type

foreign import data ValueCursor :: Type

class FromString a where
  parse :: String -> Maybe a

foreign import _showCursor :: forall cursor. cursor -> String
instance showKeyCursor :: Show KeyCursor where
  show = _showCursor

instance showValueCursor :: Show ValueCursor where
  show = _showCursor

foreign import _showDatabase :: Database -> String
instance showDatabase :: Show Database where
  show = _showDatabase

foreign import _showIndex :: Index -> String
instance showIndex :: Show Index where
  show = _showIndex

foreign import _showKeyRange :: KeyRange -> String
instance showKeyRange :: Show KeyRange where
  show = _showKeyRange

foreign import _showObjectStore :: ObjectStore -> String
instance showObjectStore :: Show ObjectStore where
  show = _showObjectStore

foreign import _showTransaction :: Transaction -> String
instance showTransaction :: Show Transaction where
  show = _showTransaction

instance showCursorDirection :: Show CursorDirection where
  show x =
    case x of
      Next       -> "next"
      NextUnique -> "nextunique"
      Prev       -> "prev"
      PrevUnique -> "prevunique"

instance showTransactionMode :: Show TransactionMode where
  show x =
    case x of
      ReadOnly      -> "readonly"
      ReadWrite     -> "readwrite"
      VersionChange -> "versionchange"

instance fromStringCursorDirection :: FromString CursorDirection where
  parse s =
    case s of
      "next"       -> Just Next
      "nextunique" -> Just NextUnique
      "prev"       -> Just Prev
      "prevunique" -> Just PrevUnique
      _            -> Nothing

instance fromStringTransactionMode :: FromString TransactionMode where
  parse s =
    case s of
      "readonly"      -> Just ReadOnly
      "readwrite"     -> Just ReadWrite
      "versionchange" -> Just VersionChange
      _               -> Nothing


Uppercase exception

Uppercase exception

-- | This module defines an effect, actions and handlers for working
-- | with Javascript exceptions.

module Control.Monad.Eff.Exception
  ( EXCEPTION()
  , Error()
  , error
  , message
  , throwException
  , catchException
  ) where

import Control.Monad.Eff (Eff())

-- | This effect is used to annotate code which possibly throws exceptions
foreign import data EXCEPTION :: !

-- | The type of Javascript errors
foreign import data Error :: *

instance showError :: Show Error where
  show = showErrorImpl

foreign import showErrorImpl
  """
  function showErrorImpl(err) {
    return err.stack || err.toString();
  }
  """ :: Error -> String

-- | Create a Javascript error, specifying a message
foreign import error
  """
  function error(msg) {
    return new Error(msg);
  }
  """ :: String -> Error

-- | Get the error message from a Javascript error
foreign import message
  """
  function message(e) {
    return e.message;
  }
  """ :: Error -> String

-- | Throw an exception
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = do
-- |   x <- readNumber
-- |   when (x < 0) $ throwException $
-- |     error "Expected a non-negative number"
-- | ```
foreign import throwException
  """
  function throwException(e) {
    return function() {
      throw e;
    };
  }
  """ :: forall a eff. Error -> Eff (err :: EXCEPTION | eff) a

-- | Catch an exception by providing an exception handler.
-- |
-- | This handler removes the `EXCEPTION` effect.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = catchException print do
-- |   trace "Exceptions thrown in this block will be logged to the console"
-- | ```
foreign import catchException
  """
  function catchException(c) {
    return function(t) {
      return function() {
        try {
          return t();
        } catch(e) {
          if (e instanceof Error || Object.prototype.toString.call(e) === '[object Error]') {
            return c(e)();
          } else {
            return c(new Error(e.toString()))();
          }
        }
      };
    };
  }
  """ :: forall a eff. (Error -> Eff eff a) -> Eff (err :: EXCEPTION | eff) a -> Eff eff a

-- | This module defines an effect, actions and handlers for working
-- | with Javascript exceptions.

module Control.Monad.Eff.Exception
  ( Exception()
  , Error()
  , error
  , message
  , throwException
  , catchException
  ) where

import Control.Monad.Eff

-- | This effect is used to annotate code which possibly throws exceptions
foreign import data Exception :: !

-- | The type of Javascript errors
foreign import data Error :: *

instance showError :: Show Error where
  show = showErrorImpl

foreign import showErrorImpl
  """
  function showErrorImpl(err) {
    return err.stack || err.toString();
  }
  """ :: Error -> String

-- | Create a Javascript error, specifying a message
foreign import error
  """
  function error(msg) {
    return new Error(msg);
  }
  """ :: String -> Error

-- | Get the error message from a Javascript error
foreign import message
  """
  function message(e) {
    return e.message;
  }
  """ :: Error -> String

-- | Throw an exception
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = do
-- |   x <- readNumber
-- |   when (x < 0) $ throwException $
-- |     error "Expected a non-negative number"
-- | ```
foreign import throwException
  """
  function throwException(e) {
    return function() {
      throw e;
    };
  }
  """ :: forall a eff. Error -> Eff (err :: Exception | eff) a

-- | Catch an exception by providing an exception handler.
-- |
-- | This handler removes the `Exception` effect.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = catchException print do
-- |   trace "Exceptions thrown in this block will be logged to the console"
-- | ```
foreign import catchException
  """
  function catchException(c) {
    return function(t) {
      return function() {
        try {
          return t();
        } catch(e) {
          if (e instanceof Error || Object.prototype.toString.call(e) === '[object Error]') {
            return c(e)();
          } else {
            return c(new Error(e.toString()))();
          }
        }
      };
    };
  }
  """ :: forall a eff. (Error -> Eff eff a) -> Eff (err :: Exception | eff) a -> Eff eff a


Use 'foldMap' in ArgParser's Lexer

Use 'foldMap' in ArgParser's Lexer

-- | ARGV lexer
-- |
-- | > Given an argv array, i.e. `process.argv`, derive a stream of tokens
-- | > suitable for parsing against a docopt specification.
-- |
-- | ===

module Language.Docopt.ArgParser.Lexer (
    lex
  , Options()
  ) where

import Prelude
import Debug.Trace
import Data.Either (Either())
import Data.Maybe (Maybe(..))
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Data.List (List(..), singleton, many, fromFoldable, some, toUnfoldable)
import Data.String (singleton) as String
import Data.Traversable (foldMap)
import Data.Foldable (elem)
import Text.Parsing.Parser (ParseError, Parser, runParser) as P
import Text.Parsing.Parser.Combinators (try, choice, optional, optionMaybe) as P
import Text.Parsing.Parser.Pos (Position(Position)) as P
import Text.Parsing.Parser.String (eof, anyChar, char, oneOf, noneOf, string) as P
import Data.Array as A
import Control.Plus (empty)
import Language.Docopt.ArgParser.Token (PositionedToken(..), Token(..))
import Language.Docopt.SpecParser.Base (space, alphaNum)
import Language.Docopt.Value (Value(..)) as D

type Options r = {
  stopAt :: Array String
  | r
}

-- | Parse a single token from the ARGV stream.
-- | Because each item on the ARGV stream is a a string itself, apply a parser
-- | to each item and derive a token.
parseToken :: P.Parser String Token
parseToken = do
  P.choice $ P.try <$> [
    lopt  <* P.eof
  , sopt  <* P.eof
  , eoa   <* P.eof
  , stdin <* P.eof
  , lit   <* P.eof
  ]

  where
    stdin :: P.Parser String Token
    stdin = do
      P.char '-'
      pure Stdin

    eoa :: P.Parser String Token
    eoa = do
      P.string "--"
      pure $ EOA empty

    -- | Parse a short option
    sopt :: P.Parser String Token
    sopt = do
      P.char '-'
      x   <- alphaNum
      xs  <- A.many $ P.noneOf [ '=' ]
      arg <- P.optionMaybe arg
      pure $ SOpt x xs arg

    -- | Parse a long option
    lopt :: P.Parser String Token
    lopt = do
      P.string "--"
      xs <- foldMap String.singleton <$> do
        some $ P.noneOf [ '=', ' ' ]
      arg <- P.optionMaybe arg
      pure $ LOpt xs arg

    -- | Parse a literal
    lit :: P.Parser String Token
    lit = Lit <<< foldMap String.singleton <$> do
      many P.anyChar

    arg = do
      P.char '='
      foldMap String.singleton <$> many P.anyChar

-- | Reduce the array of arguments (argv) to a list of tokens, by parsing each
-- | item individually.
lex
  :: forall r
   . List String
  -> Options r
  -> Either P.ParseError (List PositionedToken)
lex xs options = go xs 1
  where
    go Nil _ = pure Nil
    go (Cons x xs) n = do
      let toEOA l = pure $ singleton $ PositionedToken {
            token:     EOA (D.StringValue <$> xs)
          , sourcePos: P.Position { line: 1, column: n }
          , source:    x
          }

      tok <- P.runParser x parseToken
      case tok of
        (EOA  _) -> toEOA "--"
        otherwise -> do
          toks <- go xs (n + 1)
          pure
            $ singleton (PositionedToken {
                          token:     tok
                        , sourcePos: P.Position { line: 1, column: n }
                        , source:    x
                        }) <> toks

-- | ARGV lexer
-- |
-- | > Given an argv array, i.e. `process.argv`, derive a stream of tokens
-- | > suitable for parsing against a docopt specification.
-- |
-- | ===

module Language.Docopt.ArgParser.Lexer (
    lex
  , Options()
  ) where

import Prelude
import Debug.Trace
import Data.Either (Either())
import Data.Maybe (Maybe(..))
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Data.String (fromCharArray)
import Data.List (List(..), singleton, many, fromFoldable, some, toUnfoldable)
import Data.String (singleton) as String
import Data.Traversable (foldMap)
import Data.Foldable (elem)
import Text.Parsing.Parser (ParseError, Parser, runParser) as P
import Text.Parsing.Parser.Combinators (try, choice, optional, optionMaybe) as P
import Text.Parsing.Parser.Pos (Position(Position)) as P
import Text.Parsing.Parser.String (eof, anyChar, char, oneOf, noneOf, string) as P
import Data.Array as A
import Control.Plus (empty)
import Language.Docopt.ArgParser.Token (PositionedToken(..), Token(..))
import Language.Docopt.SpecParser.Base (space, alphaNum)
import Language.Docopt.Value (Value(..)) as D

type Options r = {
  stopAt :: Array String
  | r
}

-- | Parse a single token from the ARGV stream.
-- | Because each item on the ARGV stream is a a string itself, apply a parser
-- | to each item and derive a token.
parseToken :: P.Parser String Token
parseToken = do
  P.choice $ P.try <$> [
    lopt  <* P.eof
  , sopt  <* P.eof
  , eoa   <* P.eof
  , stdin <* P.eof
  , lit   <* P.eof
  ]

  where
    stdin :: P.Parser String Token
    stdin = do
      P.char '-'
      pure Stdin

    eoa :: P.Parser String Token
    eoa = do
      P.string "--"
      pure $ EOA empty

    -- | Parse a short option
    sopt :: P.Parser String Token
    sopt = do
      P.char '-'
      x   <- alphaNum
      xs  <- A.many $ P.noneOf [ '=' ]
      arg <- P.optionMaybe arg
      pure $ SOpt x xs arg

    -- | Parse a long option
    lopt :: P.Parser String Token
    lopt = do
      P.string "--"
      xs <- foldMap String.singleton <$> do
        some $ P.noneOf [ '=', ' ' ]
      arg <- P.optionMaybe arg
      pure $ LOpt xs arg

    -- | Parse a literal
    lit :: P.Parser String Token
    lit = Lit <<< foldMap String.singleton <$> do
      many P.anyChar

    arg = do
      P.char '='
      fromCharArray <$> A.many P.anyChar

-- | Reduce the array of arguments (argv) to a list of tokens, by parsing each
-- | item individually.
lex
  :: forall r
   . List String
  -> Options r
  -> Either P.ParseError (List PositionedToken)
lex xs options = go xs 1
  where
    go Nil _ = pure Nil
    go (Cons x xs) n = do
      let toEOA l = pure $ singleton $ PositionedToken {
            token:     EOA (D.StringValue <$> xs)
          , sourcePos: P.Position { line: 1, column: n }
          , source:    x
          }

      tok <- P.runParser x parseToken
      case tok of
        (EOA  _) -> toEOA "--"
        otherwise -> do
          toks <- go xs (n + 1)
          pure
            $ singleton (PositionedToken {
                          token:     tok
                        , sourcePos: P.Position { line: 1, column: n }
                        , source:    x
                        }) <> toks


Mark boilerplate code for removal

Mark boilerplate code for removal

module Language.Docopt.Argument.Option (
    Flag ()
  , Name ()
  , OptionObj ()
  , ArgumentObj ()
  , IsOptional ()
  , IsRepeatable ()
  , showOptionObj
  , eqOptionObj
  , isRepeatable
  , hasDefault
  , isFlag
  , takesArgument
  , prettyPrintOption
  , prettyPrintOptionNaked
  , empty
  , opt',   opt,   opt_,   optR,   optR_
  , lopt',  lopt,  lopt_,  loptR,  loptR_
  , sopt',  sopt,  sopt_,  soptR,  soptR_
  ,         optE,  optE_,  optER,  optER_
  , loptE', loptE, loptE_, loptER, loptER_
  , soptE', soptE, soptE_, soptER, soptER_
  ) where

import Prelude
import Data.Function (on)
import Control.Apply ((*>))
import Data.Maybe (Maybe(..), maybe)
import Data.Generic (class Generic, gEq, gShow)
import Data.String (fromChar)

import Language.Docopt.Value (Value(..), prettyPrintValue)

type Flag         = Char
type Name         = String
type IsRepeatable = Boolean
type IsOptional   = Boolean

type OptionObj =  { flag       :: Maybe Flag
                  , name       :: Maybe Name
                  , arg        :: Maybe ArgumentObj
                  , env        :: Maybe String
                  , repeatable :: IsRepeatable
                  }

showOptionObj :: OptionObj -> String
showOptionObj o = "{ flag: "       <> show o.flag
               <> ", name: "       <> show o.name
               <> ", arg: "        <> show (Argument <$> o.arg)
               <> ", env: "        <> show o.env
               <> ", repeatable: " <> show o.repeatable
               <> "}"

eqOptionObj :: OptionObj -> OptionObj -> Boolean
eqOptionObj o o' = o.flag               == o'.flag
                && o.name               == o'.name
                && o.env                == o'.env
                && o.repeatable         == o'.repeatable
                && (Argument <$> o.arg) == (Argument <$> o'.arg)

newtype Argument = Argument ArgumentObj

runArgument :: Argument -> ArgumentObj
runArgument (Argument a) = a

instance showArgument :: Show Argument where
  show = showArgumentObj <<< runArgument

instance eqArgument   :: Eq   Argument where
  eq   = eqArgumentObj `on` runArgument

type ArgumentObj = { name     :: String
                   , default  :: Maybe Value
                   , optional :: Boolean
                   }

showArgumentObj :: ArgumentObj -> String
showArgumentObj a = "{ name: "     <> show a.name
                 <> ", default: "  <> show a.default
                 <> ", optional: " <> show a.optional
                 <> "}"

eqArgumentObj :: ArgumentObj -> ArgumentObj -> Boolean
eqArgumentObj a a' = a.name     == a'.name
                  && a.default  == a'.default
                  && a.optional == a'.optional

empty :: OptionObj
empty = { flag:       Nothing
        , name:       Nothing
        , arg:        Nothing
        , env:        Nothing
        , repeatable: false
        }

-- TODO: Remove
isRepeatable :: OptionObj -> Boolean
isRepeatable o = o.repeatable

hasDefault :: OptionObj -> Boolean
hasDefault { arg: Just { default: Just _ } } = true
hasDefault _                                 = false

takesArgument :: OptionObj -> Boolean
takesArgument { arg: Just _ } = true
takesArgument _               = false

isFlag :: OptionObj -> Boolean
isFlag { arg: Just { default: Just (BoolValue _)}} = true
isFlag { arg: Nothing }                            = true
isFlag _                                           = false

prettyPrintOption :: OptionObj -> String
prettyPrintOption o
  = short ++ long ++ arg' ++ rep ++ default ++ env
  where
    short = maybe "" (\f -> "-" ++ (fromChar f)) o.flag
    long  = maybe "" (const ", ") (o.flag *> o.name)
              ++ maybe "" ("--" ++ _) o.name
    rep  = if o.repeatable then "..." else ""
    arg' = flip (maybe "") o.arg \({ name, optional }) ->
                (if optional then "[" else "")
                  ++ "=" ++ name
                  ++ (if optional then "]" else "")
    default = flip (maybe "") o.arg \({ default }) ->
                flip (maybe "") default \v->
                  " [default: " ++ (prettyPrintValue v) ++  "]"
    env = flip (maybe "") o.env \k -> " [env: " ++ k ++ "]"

prettyPrintOptionNaked :: OptionObj -> String
prettyPrintOptionNaked o
  = short ++ long ++ arg' ++ rep
  where
    short = maybe "" (\f -> "-" ++ (fromChar f)) o.flag
    long  = maybe "" (const "|") (o.flag *> o.name)
              ++ maybe "" ("--" ++ _) o.name
    rep  = if o.repeatable then "..." else ""
    arg' = flip (maybe "") o.arg \({ name }) -> "="  ++ name

--------------------------------------------------------------------------------
-- Short hand option creation
--
-- XXX: Remove this (!)
--------------------------------------------------------------------------------

-- short hand to create an Option argument
opt'
  :: Maybe Flag
  -> Maybe Name
  -> Maybe ArgumentObj
  -> Maybe String
  -> IsRepeatable
  -> OptionObj
opt' f n a e r = {
  flag:       f
, name:       n
, arg:        a
, env:        e
, repeatable: r
}

opt :: Flag -> Name -> ArgumentObj -> OptionObj
opt f n a = opt' (Just f) (Just n) (Just a) Nothing false

optR :: Flag -> Name -> ArgumentObj -> OptionObj
optR f n a = opt' (Just f) (Just n) (Just a) Nothing true

opt_ :: Flag -> Name -> OptionObj
opt_ f n = opt' (Just f) (Just n) Nothing Nothing false

optR_ :: Flag -> Name -> OptionObj
optR_ f n = opt' (Just f) (Just n) Nothing Nothing true

-- short hand to create an Short-OptionObj argument
sopt' :: Flag -> (Maybe ArgumentObj) -> IsRepeatable -> OptionObj
sopt' f a r = {
  flag:       pure f
, name:       Nothing
, arg:        a
, env:        Nothing
, repeatable: r
}

sopt :: Flag -> ArgumentObj -> OptionObj
sopt f a = sopt' f (Just a) false

soptR :: Flag -> ArgumentObj -> OptionObj
soptR f a = sopt' f (Just a) true

sopt_ :: Flag -> OptionObj
sopt_ f = sopt' f Nothing false

soptR_ :: Flag -> OptionObj
soptR_ f = sopt' f Nothing true

-- short hand to create an Long-OptionObj argument
lopt' :: Name -> (Maybe ArgumentObj) -> IsRepeatable -> OptionObj
lopt' n a r = {
  flag:       Nothing
, name:       pure n
, arg:        a
, env:        Nothing
, repeatable: r
}

lopt :: Name -> ArgumentObj -> OptionObj
lopt n a = lopt' n (Just a) false

loptR :: Name -> ArgumentObj -> OptionObj
loptR n a = lopt' n (Just a) true

lopt_ :: Name -> OptionObj
lopt_ n = lopt' n Nothing false

loptR_ :: Name -> OptionObj
loptR_ n = lopt' n Nothing true

--------------------------------------------------------------------------------
-- Short hand option creation (with env tag)
--------------------------------------------------------------------------------

optE :: Flag -> Name -> ArgumentObj -> String -> OptionObj
optE f n a e = opt' (Just f) (Just n) (Just a) (Just e) false

optER :: Flag -> Name -> ArgumentObj -> String -> OptionObj
optER f n a e = opt' (Just f) (Just n) (Just a) (Just e) true

optE_ :: Flag -> Name -> String -> OptionObj
optE_ f n e = opt' (Just f) (Just n) Nothing (Just e) false

optER_ :: Flag -> Name -> String -> OptionObj
optER_ f n e = opt' (Just f) (Just n) Nothing (Just e) true

-- short hand to create an Short-OptionObj argument
soptE' :: Flag -> (Maybe ArgumentObj) -> IsRepeatable -> String -> OptionObj
soptE' f a r e = {
  flag:       pure f
, name:       Nothing
, arg:        a
, env:        pure e
, repeatable: r
}

soptE :: Flag -> ArgumentObj -> String -> OptionObj
soptE f a e = soptE' f (Just a) false e

soptER :: Flag -> ArgumentObj -> String -> OptionObj
soptER f a e = soptE' f (Just a) true e

soptE_ :: Flag -> String -> OptionObj
soptE_ f e = soptE' f Nothing false e

soptER_ :: Flag -> String -> OptionObj
soptER_ f e = soptE' f Nothing true e

-- short hand to create an Long-OptionObj argument
loptE' :: Name -> (Maybe ArgumentObj) -> IsRepeatable -> String -> OptionObj
loptE' n a r e = {
  flag:       Nothing
, name:       pure n
, arg:        a
, env:        pure e
, repeatable: r
}

loptE :: Name -> ArgumentObj -> String -> OptionObj
loptE n a e = loptE' n (Just a) false e

loptER :: Name -> ArgumentObj -> String -> OptionObj
loptER n a e = loptE' n (Just a) true e

loptE_ :: Name -> String -> OptionObj
loptE_ n e = loptE' n Nothing false e

loptER_ :: Name -> String -> OptionObj
loptER_ n e = loptE' n Nothing true e

module Language.Docopt.Argument.Option (
    Flag ()
  , Name ()
  , OptionObj ()
  , ArgumentObj ()
  , IsOptional ()
  , IsRepeatable ()
  , showOptionObj
  , eqOptionObj
  , isRepeatable
  , hasDefault
  , isFlag
  , takesArgument
  , prettyPrintOption
  , prettyPrintOptionNaked
  , empty
  , opt',   opt,   opt_,   optR,   optR_
  , lopt',  lopt,  lopt_,  loptR,  loptR_
  , sopt',  sopt,  sopt_,  soptR,  soptR_
  ,         optE,  optE_,  optER,  optER_
  , loptE', loptE, loptE_, loptER, loptER_
  , soptE', soptE, soptE_, soptER, soptER_
  ) where

import Prelude
import Data.Function (on)
import Control.Apply ((*>))
import Data.Maybe (Maybe(..), maybe)
import Data.Generic (class Generic, gEq, gShow)
import Data.String (fromChar)

import Language.Docopt.Value (Value(..), prettyPrintValue)

type Flag = Char
type Name = String
type IsRepeatable = Boolean
type IsOptional = Boolean

type OptionObj =  { flag       :: Maybe Flag
                  , name       :: Maybe Name
                  , arg        :: Maybe ArgumentObj
                  , env        :: Maybe String
                  , repeatable :: IsRepeatable
                  }

showOptionObj :: OptionObj -> String
showOptionObj o = "{ flag: "       <> show o.flag
               <> ", name: "       <> show o.name
               <> ", arg: "        <> show (Argument <$> o.arg)
               <> ", env: "        <> show o.env
               <> ", repeatable: " <> show o.repeatable
               <> "}"

eqOptionObj :: OptionObj -> OptionObj -> Boolean
eqOptionObj o o' = o.flag               == o'.flag
                && o.name               == o'.name
                && o.env                == o'.env
                && o.repeatable         == o'.repeatable
                && (Argument <$> o.arg) == (Argument <$> o'.arg)

newtype Argument = Argument ArgumentObj

runArgument :: Argument -> ArgumentObj
runArgument (Argument a) = a

instance showArgument :: Show Argument where
  show = showArgumentObj <<< runArgument

instance eqArgument   :: Eq   Argument where
  eq   = eqArgumentObj `on` runArgument

type ArgumentObj = { name     :: String
                   , default  :: Maybe Value
                   , optional :: Boolean
                   }

showArgumentObj :: ArgumentObj -> String
showArgumentObj a = "{ name: "     <> show a.name
                 <> ", default: "  <> show a.default
                 <> ", optional: " <> show a.optional
                 <> "}"

eqArgumentObj :: ArgumentObj -> ArgumentObj -> Boolean
eqArgumentObj a a' = a.name     == a'.name
                  && a.default  == a'.default
                  && a.optional == a'.optional

empty :: OptionObj
empty = { flag:       Nothing
        , name:       Nothing
        , arg:        Nothing
        , env:        Nothing
        , repeatable: false
        }

-- TODO: Remove
isRepeatable :: OptionObj -> Boolean
isRepeatable o = o.repeatable

hasDefault :: OptionObj -> Boolean
hasDefault { arg: Just { default: Just _ } } = true
hasDefault _                                 = false

takesArgument :: OptionObj -> Boolean
takesArgument { arg: Just _ } = true
takesArgument _               = false

isFlag :: OptionObj -> Boolean
isFlag { arg: Just { default: Just (BoolValue _)}} = true
isFlag { arg: Nothing }                            = true
isFlag _                                           = false

prettyPrintOption :: OptionObj -> String
prettyPrintOption o
  = short ++ long ++ arg' ++ rep ++ default ++ env
  where
    short = maybe "" (\f -> "-" ++ (fromChar f)) o.flag
    long  = maybe "" (const ", ") (o.flag *> o.name)
              ++ maybe "" ("--" ++ _) o.name
    rep  = if o.repeatable then "..." else ""
    arg' = flip (maybe "") o.arg \({ name, optional }) ->
                (if optional then "[" else "")
                  ++ "=" ++ name
                  ++ (if optional then "]" else "")
    default = flip (maybe "") o.arg \({ default }) ->
                flip (maybe "") default \v->
                  " [default: " ++ (prettyPrintValue v) ++  "]"
    env = flip (maybe "") o.env \k -> " [env: " ++ k ++ "]"

prettyPrintOptionNaked :: OptionObj -> String
prettyPrintOptionNaked o
  = short ++ long ++ arg' ++ rep
  where
    short = maybe "" (\f -> "-" ++ (fromChar f)) o.flag
    long  = maybe "" (const "|") (o.flag *> o.name)
              ++ maybe "" ("--" ++ _) o.name
    rep  = if o.repeatable then "..." else ""
    arg' = flip (maybe "") o.arg \({ name }) -> "="  ++ name

--------------------------------------------------------------------------------
-- Short hand option creation
--------------------------------------------------------------------------------

-- short hand to create an Option argument
opt'
  :: Maybe Flag
  -> Maybe Name
  -> Maybe ArgumentObj
  -> Maybe String
  -> IsRepeatable
  -> OptionObj
opt' f n a e r = {
  flag:       f
, name:       n
, arg:        a
, env:        e
, repeatable: r
}

opt :: Flag -> Name -> ArgumentObj -> OptionObj
opt f n a = opt' (Just f) (Just n) (Just a) Nothing false

optR :: Flag -> Name -> ArgumentObj -> OptionObj
optR f n a = opt' (Just f) (Just n) (Just a) Nothing true

opt_ :: Flag -> Name -> OptionObj
opt_ f n = opt' (Just f) (Just n) Nothing Nothing false

optR_ :: Flag -> Name -> OptionObj
optR_ f n = opt' (Just f) (Just n) Nothing Nothing true

-- short hand to create an Short-OptionObj argument
sopt' :: Flag -> (Maybe ArgumentObj) -> IsRepeatable -> OptionObj
sopt' f a r = {
  flag:       pure f
, name:       Nothing
, arg:        a
, env:        Nothing
, repeatable: r
}

sopt :: Flag -> ArgumentObj -> OptionObj
sopt f a = sopt' f (Just a) false

soptR :: Flag -> ArgumentObj -> OptionObj
soptR f a = sopt' f (Just a) true

sopt_ :: Flag -> OptionObj
sopt_ f = sopt' f Nothing false

soptR_ :: Flag -> OptionObj
soptR_ f = sopt' f Nothing true

-- short hand to create an Long-OptionObj argument
lopt' :: Name -> (Maybe ArgumentObj) -> IsRepeatable -> OptionObj
lopt' n a r = {
  flag:       Nothing
, name:       pure n
, arg:        a
, env:        Nothing
, repeatable: r
}

lopt :: Name -> ArgumentObj -> OptionObj
lopt n a = lopt' n (Just a) false

loptR :: Name -> ArgumentObj -> OptionObj
loptR n a = lopt' n (Just a) true

lopt_ :: Name -> OptionObj
lopt_ n = lopt' n Nothing false

loptR_ :: Name -> OptionObj
loptR_ n = lopt' n Nothing true

--------------------------------------------------------------------------------
-- Short hand option creation (with env tag)
--------------------------------------------------------------------------------

optE :: Flag -> Name -> ArgumentObj -> String -> OptionObj
optE f n a e = opt' (Just f) (Just n) (Just a) (Just e) false

optER :: Flag -> Name -> ArgumentObj -> String -> OptionObj
optER f n a e = opt' (Just f) (Just n) (Just a) (Just e) true

optE_ :: Flag -> Name -> String -> OptionObj
optE_ f n e = opt' (Just f) (Just n) Nothing (Just e) false

optER_ :: Flag -> Name -> String -> OptionObj
optER_ f n e = opt' (Just f) (Just n) Nothing (Just e) true

-- short hand to create an Short-OptionObj argument
soptE' :: Flag -> (Maybe ArgumentObj) -> IsRepeatable -> String -> OptionObj
soptE' f a r e = {
  flag:       pure f
, name:       Nothing
, arg:        a
, env:        pure e
, repeatable: r
}

soptE :: Flag -> ArgumentObj -> String -> OptionObj
soptE f a e = soptE' f (Just a) false e

soptER :: Flag -> ArgumentObj -> String -> OptionObj
soptER f a e = soptE' f (Just a) true e

soptE_ :: Flag -> String -> OptionObj
soptE_ f e = soptE' f Nothing false e

soptER_ :: Flag -> String -> OptionObj
soptER_ f e = soptE' f Nothing true e

-- short hand to create an Long-OptionObj argument
loptE' :: Name -> (Maybe ArgumentObj) -> IsRepeatable -> String -> OptionObj
loptE' n a r e = {
  flag:       Nothing
, name:       pure n
, arg:        a
, env:        pure e
, repeatable: r
}

loptE :: Name -> ArgumentObj -> String -> OptionObj
loptE n a e = loptE' n (Just a) false e

loptER :: Name -> ArgumentObj -> String -> OptionObj
loptER n a e = loptE' n (Just a) true e

loptE_ :: Name -> String -> OptionObj
loptE_ n e = loptE' n Nothing false e

loptER_ :: Name -> String -> OptionObj
loptER_ n e = loptE' n Nothing true e


Add comments

Add comments

module Docopt.Parser.Docopt where

import Prelude
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.List (List(), many, toList, fromList, (:))
import Data.String (fromCharArray)
import Docopt.Parser.Base

data Section
  = Preamble String
  | Usage String
  | Options String

data Docopt = Docopt (List Section)

instance showDocopt :: Show Docopt where
  show (Docopt xs) = "Docopt " ++ show xs

instance showSection :: Show Section where
  show (Preamble x) = "Preamble: " ++ show x
  show (Usage    x) = "Usage: "    ++ show x
  show (Options  x) = "Options: "  ++ show x

-- | Pre-parse the docopt string and break it into
--   sections.
prelex :: P.Parser String Docopt
prelex = do
  preamble <- Preamble <$> parseSectionSource
  sections <- many $ P.try do
    parseSectionCons <*> parseSectionSource
  return $ Docopt $ preamble:sections

-- | Parse the body of a section.
--   The body of a section is defined as the string until
--   another section starts or the EOF is met.
parseSectionSource :: P.Parser String String
parseSectionSource = fromCharArray <<< fromList <$> do
  P.manyTill
    P.anyChar
    (P.lookAhead (void parseSectionCons) <|> P.eof)

-- | Parse a section header and partially apply the
--   corresponding Section constructor
parseSectionCons :: P.Parser String (String -> Section)
parseSectionCons = do
  P.Position { column: col }  <- getPosition
  (guard $ col == 1) P.<?> "Section to be anchored"
  many space
  P.choice
    [ P.string "Usage:"   *> pure Usage
    , P.string "Options:" *> pure Options
    ]

module Docopt.Parser.Docopt where

import Prelude
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.List (List(), many, toList, fromList, (:))
import Data.String (fromCharArray)
import Docopt.Parser.Base

data Section
  = Preamble String
  | Usage String
  | Options String

data Docopt = Docopt (List Section)

instance showDocopt :: Show Docopt where
  show (Docopt xs) = "Docopt " ++ show xs

instance showSection :: Show Section where
  show (Preamble x) = "Preamble: " ++ show x
  show (Usage    x) = "Usage: "    ++ show x
  show (Options  x) = "Options: "  ++ show x

prelex :: P.Parser String Docopt
prelex = do
  preamble <- Preamble <$> parseSectionSource
  sections <- many $ P.try do
    parseSectionCons <*> parseSectionSource
  return $ Docopt $ preamble:sections

parseSectionSource :: P.Parser String String
parseSectionSource = fromCharArray <<< fromList <$> do
  P.manyTill
    P.anyChar
    (P.lookAhead (void parseSectionCons) <|> P.eof)

parseSectionCons :: P.Parser String (String -> Section)
parseSectionCons = do
  P.Position { column: col }  <- getPosition
  (guard $ col == 1) P.<?> "Section to be anchored"
  many space
  P.choice
    [ P.string "Usage:"   *> pure Usage
    , P.string "Options:" *> pure Options
    ]


Kick players who have been idle for too long

refs #6

TODO: send a close reason, and have a better UI on the client, for when
this happens

module BaseServer where

import Debug.Trace (Trace(), trace)
import Data.Maybe
import Data.Tuple
import Data.Foldable (for_, find)
import Data.Array (map, head, null, filter, (\\))
import qualified Data.Either as E
import qualified Data.String as S
import qualified Data.Map as M
import Data.Monoid (Monoid, mempty)
import Data.JSON
import Control.Monad (when)
import Control.Monad.RWS
import Control.Monad.RWS.Class
import qualified Control.Monad.Writer.Class as W
import qualified Control.Monad.Reader.Class as R
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (newRef, readRef, writeRef, modifyRef, Ref(),
                              RefVal())
import Control.Reactive.Timer (Timer(), interval)
import Control.Lens (lens, (^.), (%~), (.~), at, LensP())

import Types
import BaseCommon
import qualified NodeWebSocket as WS
import Utils

idleInterval = 30 * 1000

type Server st =
  { connections :: [Connection]
  , state       :: st
  , timeCounter :: Number -- for tracking whether players are idle
  }

connections = lens (\s -> s.connections) (\s x -> s { connections = x })
timeCounter = lens (\s -> s.timeCounter) (\s x -> s { timeCounter = x })

newtype Connection =
  Connection
    { wsConn      :: WS.Connection
    , pId         :: PlayerId
    , name        :: String
    , timeCounter :: Number -- for tracking whether the player is idle
    }

cWsConn = lens
  (\(Connection c) -> c.wsConn)
  (\(Connection c) x -> Connection $ c { wsConn = x })

cPId = lens
  (\(Connection c) -> c.pId)
  (\(Connection c) x -> Connection $ c { pId = x })

cName = lens
  (\(Connection c) -> c.name)
  (\(Connection c) x -> Connection $ c { name = x })

cTimeCounter = lens
  (\(Connection c) -> c.timeCounter)
  (\(Connection c) x -> Connection $ c { timeCounter = x })

connectionsToPlayersMap :: [Connection] -> M.Map PlayerId String
connectionsToPlayersMap =
  map (\(Connection c) -> Tuple c.pId c.name) >>> M.fromList

type ServerCallbacks st inc outg =
  { step        :: ServerM st outg Unit
  , onNewPlayer :: PlayerId -> ServerM st outg Unit
  , onMessage   :: inc -> PlayerId -> ServerM st outg Unit
  , onClose     :: PlayerId -> ServerM st outg Unit
  }

newtype SendMessages outg
  = SendMessages
    { toAll :: [outg]
    , toOne :: M.Map PlayerId [outg]
    }

instance semigroupSendMsgs :: Semigroup (SendMessages outg) where
  (<>) (SendMessages a) (SendMessages b) =
    SendMessages { toAll: a.toAll <> b.toAll
                 , toOne: unionWith (<>) a.toOne b.toOne
                 }

instance monoidSendMsgs :: Monoid (SendMessages outg) where
  mempty = SendMessages { toAll: [], toOne: M.empty }

type ServerM st outg a =
  RWS [Connection] (SendMessages outg) st a

type ServerMResult st outg a =
  { nextState :: st
  , messages  :: SendMessages outg
  , result    :: a
  }

runServerM :: forall st outg a.
  [Connection] -> st -> ServerM st outg a -> ServerMResult st outg a
runServerM conns state action =
  let r = runRWS action conns state
  in { nextState: r.state
     , messages:  r.log
     , result:    r.result
     }

mkServer :: forall st. st -> Server st
mkServer initialState =
  { connections: []
  , state: initialState
  , timeCounter: 0
  }

runCallback :: forall st outg args e. (ToJSON outg) =>
  RefVal (Server st) -> ServerM st outg Unit
  -> Eff (ServerEffects e) Unit
runCallback refSrv callback = do
  srv <- readRef refSrv
  let res = runServerM srv.connections srv.state callback
  sendAllMessages srv res.messages
  writeRef refSrv $ srv { state = res.nextState }

messagesFor :: forall outg. PlayerId -> SendMessages outg -> [outg]
messagesFor pId (SendMessages sm) =
  sm.toAll <> fromMaybe [] (M.lookup pId sm.toOne)

sendAllMessages :: forall e st outg. (ToJSON outg) =>
  Server st -> SendMessages outg
  -> Eff (ServerEffects e) Unit
sendAllMessages srv sm = do
  for_ srv.connections $ \conn ->
    let msgs = messagesFor (conn ^. cPId) sm
    in when (not (null msgs)) $ do
      for_ msgs $ \msg ->
        WS.send (conn ^. cWsConn) (encode msg)

sendUpdate :: forall m outg. (Monad m, W.MonadWriter (SendMessages outg) m) =>
  outg -> m Unit
sendUpdate m = sendUpdates [m]

sendUpdates :: forall m outg. (Monad m, W.MonadWriter (SendMessages outg) m) =>
  [outg] -> m Unit
sendUpdates ms =
  W.tell $ SendMessages { toAll: ms, toOne: M.empty }

sendUpdateTo :: forall m outg. (Monad m, W.MonadWriter (SendMessages outg) m) =>
  PlayerId -> outg -> m Unit
sendUpdateTo pId m =
  W.tell $ SendMessages { toAll: [], toOne: M.insert pId [m] M.empty }

askPlayers :: forall m. (Monad m, R.MonadReader [Connection] m) =>
  m (M.Map PlayerId String)
askPlayers =
  connectionsToPlayersMap <$> R.ask

stepsPerSecond = 30

type ServerEffects e =
  (timer :: Timer, ref :: Ref, trace :: Trace, ws :: WS.WebSocket | e)

startServer :: forall st inc outg e. (FromJSON inc, ToJSON outg) =>
  ServerCallbacks st inc outg -> RefVal (Server st)
  -> Eff (ServerEffects e) WS.Server
startServer cs refSrv = do
  server <- WS.mkServer

  WS.onRequest server $ \req -> do
    trace "got a request"
    let playerName = decodeUriComponent (S.drop 1 (WS.resourceUrl req).search)

    if S.null playerName
      then WS.reject req
      else do
        conn <- WS.accept req
        maybePId <- tryAddPlayer conn refSrv playerName

        case maybePId of
          Just pId -> do
            trace $ "opened connection for player " <>
                        show pId <> ": " <> playerName
            handleNewPlayer refSrv pId
            runCallback refSrv $ cs.onNewPlayer pId

            WS.onMessage conn $ \msg -> do
              updatePlayerTimeCounter refSrv pId
              case eitherDecode msg of
                E.Right val -> runCallback refSrv $ cs.onMessage val pId
                E.Left err  -> trace err

            WS.onClose   conn $ \close -> do
              closeConnection refSrv pId
              runCallback refSrv $ cs.onClose pId

          Nothing -> do
            trace "rejecting connection, no player ids available"
            WS.close conn

  void $ interval (1000 / stepsPerSecond) $
    runCallback refSrv $ cs.step

  interval idleInterval $ do
    kickIdlePlayers refSrv
    updateServerTimeCounter refSrv

  return server

tryAddPlayer conn refSrv name = do
  srv <- readRef refSrv
  case getNextPlayerId srv of
    Just pId -> do
      let srv' = srv { connections = srv.connections <>
                              [Connection { pId: pId
                                          , wsConn: conn
                                          , name: name
                                          , timeCounter: srv.timeCounter
                                          }] }
      writeRef refSrv srv'
      return (Just pId)
    Nothing ->
      return Nothing

getNextPlayerId :: forall st. Server st -> Maybe PlayerId
getNextPlayerId srv =
  let playerIdsInUse = (\c -> c ^. cPId) <$> srv.connections
  in  head $ allPlayerIds \\ playerIdsInUse

handleNewPlayer :: forall st e.
  RefVal (Server st) -> PlayerId -> Eff (ServerEffects e) Unit
handleNewPlayer refSrv pId = do
  srv <- readRef refSrv
  let playersMap = connectionsToPlayersMap srv.connections
  let msgAll = NewPlayer playersMap
  let msgOne = YourPlayerIdIs pId
  let msgs = SendMessages { toAll: [msgAll]
                          , toOne: M.singleton pId [msgOne]
                          }
  trace $ "new player connected, sending to all: " <> encode msgAll
  trace $ "                      sending to one: " <> encode msgOne
  sendAllMessages srv msgs

closeConnection :: forall st e.
  RefVal (Server st) -> PlayerId -> Eff (ServerEffects e) Unit
closeConnection refSrv pId = do
  modifyRef refSrv $ connections %~ filter (\c -> pId /= c ^. cPId)
  trace $ "closed connection for " <> show pId

updatePlayerTimeCounter refSrv pId = do
  srv <- readRef refSrv
  let mConn = find (\c -> c ^. cPId == pId) srv.connections
  whenJust mConn $ \conn -> do
    let conn' = conn # cTimeCounter .~ srv.timeCounter
    let conns' = filter (\c -> pId /= c ^. cPId) srv.connections
    let conns'' = conns' <> [conn']
    modifyRef refSrv $ connections .~ conns''

kickIdlePlayers refSrv = do
  srv <- readRef refSrv
  let idles = filter (\c -> c ^. cTimeCounter /= srv.timeCounter)
                     srv.connections
  for_ idles $ \c -> do
    WS.close (c ^. cWsConn)

updateServerTimeCounter refSrv =
  modifyRef refSrv $ timeCounter %~ ((+) 1)

foreign import decodeUriComponent """
  function decodeUriComponent(string) {
    return global.decodeURIComponent(string)
  }
""" :: String -> String

module BaseServer where

import Debug.Trace (Trace(), trace)
import Data.Maybe
import Data.Tuple
import Data.Foldable (for_, find)
import Data.Array (map, head, null, filter, (\\))
import qualified Data.Either as E
import qualified Data.String as S
import qualified Data.Map as M
import Data.Monoid (Monoid, mempty)
import Data.JSON
import Control.Monad (when)
import Control.Monad.RWS
import Control.Monad.RWS.Class
import qualified Control.Monad.Writer.Class as W
import qualified Control.Monad.Reader.Class as R
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Ref (newRef, readRef, writeRef, modifyRef, Ref(),
                              RefVal())
import Control.Reactive.Timer (Timer(), interval)
import Control.Lens (lens, (^.), (%~), (.~), at, LensP())

import Types
import BaseCommon
import qualified NodeWebSocket as WS
import Utils (unionWith)

type Server st =
  { connections :: [Connection]
  , state :: st
  }

connections = lens (\s -> s.connections) (\s x -> s { connections = x })

newtype Connection =
  Connection
    { wsConn :: WS.Connection
    , pId :: PlayerId
    , name :: String
    }

cWsConn = lens
  (\(Connection c) -> c.wsConn)
  (\(Connection c) x -> Connection $ c { wsConn = x })

cPId = lens
  (\(Connection c) -> c.pId)
  (\(Connection c) x -> Connection $ c { pId = x })

cName = lens
  (\(Connection c) -> c.name)
  (\(Connection c) x -> Connection $ c { name = x })

connectionsToPlayersMap :: [Connection] -> M.Map PlayerId String
connectionsToPlayersMap =
  map (\(Connection c) -> Tuple c.pId c.name) >>> M.fromList

type ServerCallbacks st inc outg =
  { step        :: ServerM st outg Unit
  , onNewPlayer :: PlayerId -> ServerM st outg Unit
  , onMessage   :: inc -> PlayerId -> ServerM st outg Unit
  , onClose     :: PlayerId -> ServerM st outg Unit
  }

newtype SendMessages outg
  = SendMessages
    { toAll :: [outg]
    , toOne :: M.Map PlayerId [outg]
    }

instance semigroupSendMsgs :: Semigroup (SendMessages outg) where
  (<>) (SendMessages a) (SendMessages b) =
    SendMessages { toAll: a.toAll <> b.toAll
                 , toOne: unionWith (<>) a.toOne b.toOne
                 }

instance monoidSendMsgs :: Monoid (SendMessages outg) where
  mempty = SendMessages { toAll: [], toOne: M.empty }

type ServerM st outg a =
  RWS [Connection] (SendMessages outg) st a

type ServerMResult st outg a =
  { nextState :: st
  , messages  :: SendMessages outg
  , result    :: a
  }

runServerM :: forall st outg a.
  [Connection] -> st -> ServerM st outg a -> ServerMResult st outg a
runServerM conns state action =
  let r = runRWS action conns state
  in { nextState: r.state
     , messages:  r.log
     , result:    r.result
     }

mkServer :: forall st. st -> Server st
mkServer initialState =
  { connections: []
  , state: initialState
  }

runCallback :: forall st outg args e. (ToJSON outg) =>
  RefVal (Server st) -> ServerM st outg Unit
  -> Eff (ServerEffects e) Unit
runCallback refSrv callback = do
  srv <- readRef refSrv
  let res = runServerM srv.connections srv.state callback
  sendAllMessages srv res.messages
  writeRef refSrv $ srv { state = res.nextState }

messagesFor :: forall outg. PlayerId -> SendMessages outg -> [outg]
messagesFor pId (SendMessages sm) =
  sm.toAll <> fromMaybe [] (M.lookup pId sm.toOne)

sendAllMessages :: forall e st outg. (ToJSON outg) =>
  Server st -> SendMessages outg
  -> Eff (ServerEffects e) Unit
sendAllMessages srv sm = do
  for_ srv.connections $ \conn ->
    let msgs = messagesFor (conn ^. cPId) sm
    in when (not (null msgs)) $ do
      for_ msgs $ \msg ->
        WS.send (conn ^. cWsConn) (encode msg)

sendUpdate :: forall m outg. (Monad m, W.MonadWriter (SendMessages outg) m) =>
  outg -> m Unit
sendUpdate m = sendUpdates [m]

sendUpdates :: forall m outg. (Monad m, W.MonadWriter (SendMessages outg) m) =>
  [outg] -> m Unit
sendUpdates ms =
  W.tell $ SendMessages { toAll: ms, toOne: M.empty }

sendUpdateTo :: forall m outg. (Monad m, W.MonadWriter (SendMessages outg) m) =>
  PlayerId -> outg -> m Unit
sendUpdateTo pId m =
  W.tell $ SendMessages { toAll: [], toOne: M.insert pId [m] M.empty }

askPlayers :: forall m. (Monad m, R.MonadReader [Connection] m) =>
  m (M.Map PlayerId String)
askPlayers =
  connectionsToPlayersMap <$> R.ask

stepsPerSecond = 30

type ServerEffects e =
  (timer :: Timer, ref :: Ref, trace :: Trace, ws :: WS.WebSocket | e)

startServer :: forall st inc outg e. (FromJSON inc, ToJSON outg) =>
  ServerCallbacks st inc outg -> RefVal (Server st)
  -> Eff (ServerEffects e) WS.Server
startServer cs refSrv = do
  server <- WS.mkServer

  WS.onRequest server $ \req -> do
    trace "got a request"
    let playerName = decodeUriComponent (S.drop 1 (WS.resourceUrl req).search)

    if S.null playerName
      then WS.reject req
      else do
        conn <- WS.accept req
        maybePId <- tryAddPlayer conn refSrv playerName

        case maybePId of
          Just pId -> do
            trace $ "opened connection for player " <>
                        show pId <> ": " <> playerName
            handleNewPlayer refSrv pId
            runCallback refSrv $ cs.onNewPlayer pId

            WS.onMessage conn $ \msg ->
              case eitherDecode msg of
                E.Right val -> runCallback refSrv $ cs.onMessage val pId
                E.Left err  -> trace err
            WS.onClose   conn $ \close -> do
              closeConnection refSrv pId
              runCallback refSrv $ cs.onClose pId
          Nothing -> do
            trace "rejecting connection, no player ids available"
            WS.close conn

  void $ interval (1000 / stepsPerSecond) $
    runCallback refSrv $ cs.step

  return server

tryAddPlayer conn refSrv name = do
  srv <- readRef refSrv
  case getNextPlayerId srv of
    Just pId -> do
      let srv' = srv { connections = srv.connections <>
                              [Connection { pId: pId
                                          , wsConn: conn
                                          , name: name }] }
      writeRef refSrv srv'
      return (Just pId)
    Nothing ->
      return Nothing

getNextPlayerId :: forall st. Server st -> Maybe PlayerId
getNextPlayerId srv =
  let playerIdsInUse = (\c -> c ^. cPId) <$> srv.connections
  in  head $ allPlayerIds \\ playerIdsInUse

handleNewPlayer :: forall st e.
  RefVal (Server st) -> PlayerId -> Eff (ServerEffects e) Unit
handleNewPlayer refSrv pId = do
  srv <- readRef refSrv
  let playersMap = connectionsToPlayersMap srv.connections
  let msgAll = NewPlayer playersMap
  let msgOne = YourPlayerIdIs pId
  let msgs = SendMessages { toAll: [msgAll]
                          , toOne: M.singleton pId [msgOne]
                          }
  trace $ "new player connected, sending to all: " <> encode msgAll
  trace $ "                      sending to one: " <> encode msgOne
  sendAllMessages srv msgs

closeConnection :: forall st e.
  RefVal (Server st) -> PlayerId -> Eff (ServerEffects e) Unit
closeConnection refSrv pId = do
  modifyRef refSrv $ connections %~ filter (\c -> pId /= c ^. cPId)
  trace $ "closed connection for " <> show pId

foreign import decodeUriComponent """
  function decodeUriComponent(string) {
    return global.decodeURIComponent(string)
  }
""" :: String -> String


rev import

rev import


Fix incomplete pattern match in test

Fix incomplete pattern match in test

module Test.Authorization where

import Prelude (Unit, bind, ($), map, show, pure)

import Control.Monad.Aff (forkAff,later', launchAff, attempt)
import Control.Monad.Aff.Par (Par(..), runPar)
import Control.Monad.Aff.AVar (AVAR(), makeVar, takeVar, putVar)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), message)
import Control.Alt ((<|>))
import Data.Either (either)
import Data.Maybe (Maybe(Just))
import Data.Foreign (toForeign)
import Web.Firebase.Types as FBT
import Web.Firebase (EventType(..),once, pushE, push)
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase.Monad.Aff (onceValue, on, firebaseErrToString)

authorizationSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff, err :: EXCEPTION, avar :: AVAR | eff ) Unit
authorizationSpec forbiddenRef = do
    describe "Understanding AVar and Par" do
      it "can write to a var" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar true)
        actual <- takeVar respVar
        actual `shouldEqual` true
      it "can race two vars manually" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar "fast")
        handleSlow <- forkAff (later' 200 $ putVar respVar "slow")
        actual <- takeVar respVar
        actual `shouldEqual` "fast"
      it "can race two vars with an alternative" do
        let fast = (later' 100 $ pure "fast")
            slow = (later' 200 $ pure "slow")
        actual <- runPar (Par fast <|> Par slow)
        actual `shouldEqual` "fast"
    describe "Authorization" do
      describe "Writing" do
        it "pushE() on forbidden location calls error callback" do
          respVar <- makeVar
          handle  <- liftEff $ pushE (toForeign {some: "object"}) (\err -> launchAff $ putVar respVar (map show err)) forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` Just "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED"
        it "push() on forbidden location calls error callback" do
          respVar <- makeVar
          handle  <- liftEff $ push (toForeign {some: "object"}) (Just (Just (\err -> launchAff $ putVar respVar (firebaseErrToString err)))) forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED"
      describe "once() on forbidden location" do
        it "with Eff calls an error callback" do
          respVar <- makeVar
          handle  <- liftEff $ once ChildAdded (\snap -> launchAff $ putVar respVar "unexpected sucess") (\_ -> launchAff $ putVar respVar "child forbidden") forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "child forbidden"
        it "with Aff throws an error" do
           e <- attempt $ onceValue forbiddenRef  -- catch error thrown and assert
           either (\err -> (message err) `shouldEqual` "permission_denied at /forbidden: Client doesn't have permission to access the desired data.\n | firebase code: | \n PERMISSION_DENIED") (\_ -> "expected an error to be thrown" `shouldEqual` "but was not") e
      describe "on() at forbidden location" do
        it "ChildAdded with Aff throws an error" do
          expectError $ on ChildAdded forbiddenRef
        it "ChildRemoved with Aff throws an error" do
          expectError $ on ChildRemoved forbiddenRef
        it "ChildChanged with Aff throws an error" do
          expectError $ on ChildChanged forbiddenRef
        it "ChildMoved with Aff throws an error" do
          expectError $ on ChildMoved forbiddenRef

{-   describe "Firebase API breaks its documentation" do
       it "once() throws an exeption when no error callback provided and an error occurs" do
          -- I prefer handling errors, but this is the firebase api...
          handle <- liftEff $ once ChildAdded (\_ -> pure unit) Nothing forbiddenRef
          "shoul get here" `shouldEqual` "should get here"
-}

module Test.Authorization where

import Prelude (Unit, bind, ($), pure)

import Control.Monad.Aff (forkAff,later', launchAff, attempt)
import Control.Monad.Aff.Par (Par(..), runPar)
import Control.Monad.Aff.AVar (AVAR(), makeVar, takeVar, putVar)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), message)
import Control.Alt ((<|>))
import Data.Either (either)
import Data.Maybe (Maybe(Just))
import Data.Foreign (toForeign)
import Web.Firebase.Types as FBT
import Web.Firebase (EventType(..),once, pushE, push)
import Test.Spec                  (describe, it, Spec())
import Test.Spec.Assertions       (shouldEqual)
import Test.Spec.Assertions.Aff (expectError)
import Web.Firebase.Monad.Aff (onceValue, on, firebaseErrToString)

authorizationSpec :: forall eff. FBT.Firebase -> Spec (firebase :: FBT.FirebaseEff, err :: EXCEPTION, avar :: AVAR | eff ) Unit
authorizationSpec forbiddenRef = do
    describe "Understanding AVar and Par" do
      it "can write to a var" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar true)
        actual <- takeVar respVar
        actual `shouldEqual` true
      it "can race two vars manually" do
        respVar <- makeVar
        handle <- forkAff (later' 100 $ putVar respVar "fast")
        handleSlow <- forkAff (later' 200 $ putVar respVar "slow")
        actual <- takeVar respVar
        actual `shouldEqual` "fast"
      it "can race two vars with an alternative" do
        let fast = (later' 100 $ pure "fast")
            slow = (later' 200 $ pure "slow")
        actual <- runPar (Par fast <|> Par slow)
        actual `shouldEqual` "fast"
    describe "Authorization" do
      describe "Writing" do
        it "pushE() on forbidden location calls error callback" do
          respVar <- makeVar
          handle  <- liftEff $ pushE (toForeign {some: "object"}) (\(Just err) -> launchAff $ putVar respVar (firebaseErrToString err)) forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED"
        it "push() on forbidden location calls error callback" do
          respVar <- makeVar
          handle  <- liftEff $ push (toForeign {some: "object"}) (Just (Just (\err -> launchAff $ putVar respVar (firebaseErrToString err)))) forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "PERMISSION_DENIED: Permission denied\n | firebase code: | \n PERMISSION_DENIED"
      describe "once() on forbidden location" do
        it "with Eff calls an error callback" do
          respVar <- makeVar
          handle  <- liftEff $ once ChildAdded (\snap -> launchAff $ putVar respVar "unexpected sucess") (\_ -> launchAff $ putVar respVar "child forbidden") forbiddenRef
          actual <- takeVar respVar
          actual `shouldEqual` "child forbidden"
        it "with Aff throws an error" do
           e <- attempt $ onceValue forbiddenRef  -- catch error thrown and assert
           either (\err -> (message err) `shouldEqual` "permission_denied at /forbidden: Client doesn't have permission to access the desired data.\n | firebase code: | \n PERMISSION_DENIED") (\_ -> "expected an error to be thrown" `shouldEqual` "but was not") e
      describe "on() at forbidden location" do
        it "ChildAdded with Aff throws an error" do
          expectError $ on ChildAdded forbiddenRef
        it "ChildRemoved with Aff throws an error" do
          expectError $ on ChildRemoved forbiddenRef
        it "ChildChanged with Aff throws an error" do
          expectError $ on ChildChanged forbiddenRef
        it "ChildMoved with Aff throws an error" do
          expectError $ on ChildMoved forbiddenRef

{-   describe "Firebase API breaks its documentation" do
       it "once() throws an exeption when no error callback provided and an error occurs" do
          -- I prefer handling errors, but this is the firebase api...
          handle <- liftEff $ once ChildAdded (\_ -> pure unit) Nothing forbiddenRef
          "shoul get here" `shouldEqual` "should get here"
-}


Better syntax highlighting

Better syntax highlighting

module Main (main) where

import Data.Function

import qualified Thermite as T
import qualified Thermite.Html as T
import qualified Thermite.Html.Elements as T
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Events as T

data Action = TextChanged String | ClearText

data State = State { name :: String }

data Props = Props { greeting :: String }

foreign import unsafeStringValue
  "function unsafeStringValue(e) {\
  \  return e.target.value;\
  \}" :: T.FormEvent -> String

initialState :: State
initialState = State { name: "" }

render :: T.Render State Props Action
render = mkFn3 render'
  where
  render' :: T.Context Action -> State -> Props -> T.Html Action
  render' ctx (State s) (Props p) = T.div' $ welcome : response s.name
    where
    welcome :: T.Html _
    welcome =
      T.div'
        [ T.input [ A.value s.name, A.placeholder "What is your name?", T.onChange ctx (TextChanged <<< unsafeStringValue) ] []
        , T.button [ T.onClick ctx (\_ -> TextChanged "") ] [ T.text "Clear" ]
        ]

    response :: String -> [T.Html _]
    response "" = []
    response s =
      [ T.div'
          [ T.text p.greeting
          , T.text s
          ]
      ]

performAction :: T.PerformAction State Props Action _
performAction = mkFn3 \_ _ (TextChanged s) k -> k (State { name: s })

spec :: T.Spec _ State Props Action
spec = T.Spec { initialState: initialState
              , performAction: performAction
              , render: render
              }

main = do
  let component = T.createClass spec
  T.render component (Props { greeting: "Hello, " })

module Main (main) where

import Data.Function

import qualified Thermite as T
import qualified Thermite.Html as T
import qualified Thermite.Html.Elements as T
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Events as T

data Action = TextChanged String | ClearText

data State = State { name :: String }

data Props = Props { greeting :: String }

foreign import unsafeStringValue """
  function unsafeStringValue(e) {
    return e.target.value;
  }
  """ :: T.FormEvent -> String

initialState :: State
initialState = State { name: "" }

render :: T.Render State Props Action
render = mkFn3 render'
  where
  render' :: T.Context Action -> State -> Props -> T.Html Action
  render' ctx (State s) (Props p) = T.div' $ welcome : response s.name
    where
    welcome :: T.Html _
    welcome =
      T.div'
        [ T.input [ A.value s.name, A.placeholder "What is your name?", T.onChange ctx (TextChanged <<< unsafeStringValue) ] []
        , T.button [ T.onClick ctx (\_ -> TextChanged "") ] [ T.text "Clear" ]
        ]

    response :: String -> [T.Html _]
    response "" = []
    response s =
      [ T.div'
          [ T.text p.greeting
          , T.text s
          ]
      ]

performAction :: T.PerformAction State Props Action _
performAction = mkFn3 \_ _ (TextChanged s) k -> k (State { name: s })

spec :: T.Spec _ State Props Action
spec = T.Spec { initialState: initialState
              , performAction: performAction
              , render: render
              }

main = do
  let component = T.createClass spec
  T.render component (Props { greeting: "Hello, " })