Cleaned up the imports in the tests.

Cleaned up the imports in the tests.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/gcross/habit-of-fate.git/'


Move `PG` into separate module

Move `PG` into separate module

module Database.PostgreSQL.PG
( module Row
, module Value
, module PostgreSQL
, PG
, command
, execute
, query
, onIntegrityError
, scalar
, withConnection
, withTransaction
) where

import Prelude

import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (ExceptT(..))
import Control.Monad.Except.Trans (ExceptT, runExceptT)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Database.PostgreSQL (Connection, PGError(..), Pool, Query)
import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, class ToSQLValue, Connection, Database, PGError(..), PGErrorDetail, Pool, PoolConfiguration, Query(..), Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), defaultPoolConfiguration, fromSQLRow, fromSQLValue, instantFromString, instantToString, newPool, null, toSQLRow, toSQLValue, unsafeIsBuffer) as PostgreSQL
import Database.PostgreSQL (command, execute, query, scalar, withConnection, withTransaction) as P
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), fromSQLRow, toSQLRow) as Row
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row1)
import Database.PostgreSQL.Value (class FromSQLValue)
import Database.PostgreSQL.Value (class FromSQLValue, class ToSQLValue, fromSQLValue, instantFromString, instantToString, null, toSQLValue, unsafeIsBuffer) as Value
import Effect.Aff (Aff)

type Database = String

-- | PostgreSQL computations run in the `PG` monad. It's just `Aff` stacked with
-- | `ExceptT` to provide error handling.
-- |
-- | Errors originating from database queries or connection to the database are
-- | modeled with the `PGError` type. Use `runExceptT` from
-- | `Control.Monad.Except.Trans` to turn a `PG a` action into `Aff (Either
-- | PGError a)`.
type PG a = ExceptT PGError Aff a

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
withConnection
    :: forall a
     . Pool
    -> (Connection -> PG a)
    -> PG a
withConnection p k = ExceptT $ P.withConnection p case _ of
  Right conn -> runExceptT $ k conn
  Left pgErr -> pure (Left pgErr)

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns cleanly, and rolled back if the action throws (either a
-- | `PGError` or a JavaScript exception in PG context). If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: forall a
     . Connection
    -> PG a
    -> PG a
withTransaction conn action =
  ExceptT $ join <$> P.withTransaction conn (runExceptT action)

-- | Execute a PostgreSQL query and discard its results.
execute
    :: forall i o
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> PG Unit
execute conn sql values = ExceptT $ P.execute conn sql values >>= case _ of
  Just pgErr -> pure (Left pgErr)
  Nothing -> pure (Right unit)

-- | Execute a PostgreSQL query and return its results.
query
    :: forall i o
     . ToSQLRow i
    => FromSQLRow o
    => Connection
    -> Query i o
    -> i
    -> PG (Array o)
query conn sql = ExceptT <<< P.query conn sql

-- | Execute a PostgreSQL query and return the first field of the first row in
-- | the result.
scalar
    :: forall i o
     . ToSQLRow i
    => FromSQLValue o
    => Connection
    -> Query i (Row1 o)
    -> i
    -> PG (Maybe o)
scalar conn sql = ExceptT <<< P.scalar conn sql

-- | Execute a PostgreSQL query and return its command tag value
-- | (how many rows were affected by the query). This may be useful
-- | for example with `DELETE` or `UPDATE` queries.
command
    :: forall i
     . ToSQLRow i
    => Connection
    -> Query i Int
    -> i
    -> PG Int
command conn sql = ExceptT <<< P.command conn sql

onIntegrityError :: forall a. PG a -> PG a -> PG a
onIntegrityError errorResult db =
    catchError db handleError
    where
    handleError e =
        case e of
            IntegrityError _ -> errorResult
            _ -> throwError e

error: pathspec 'src/Database/PostgreSQL/PG.purs' did not match any file(s) known to git


added purescript version of Text.Parsing.Indent from hackage

module IndentParser (
    -- $doc
    -- * Types
    IndentParser, runIndent,
    -- * Blocks
    withBlock, withBlock', block,
    -- * Indentation Checking
    indented, same, sameOrIndented, checkIndent, withPos,
    -- * Paired characters
    -- indentBrackets, indentAngles, indentBraces, indentParens,
    -- * Line Fold Chaining
    -- | Any chain using these combinators must used with 'withPos'
    indentAp, (<+/>), indentNoAp, (<-/>), indentMany, (<*/>), indentOp, (<?/>), Optional(..)
) where

import Prelude (class Monad, Unit, id, ap, const, ($), flip, unit, return, (==), bind, (<=))
import Data.List (List(..), many)
import Data.Maybe (Maybe(..))

import Control.Alt ((<|>))
import Control.Apply ((*>), lift2)
import Control.Monad.Trans (lift)
import Control.Monad.State (State, evalState)
import Control.Monad.State.Trans (get, put)
import Data.Either (Either(..))

import Text.Parsing.Parser (ParseError, ParserT(..), PState(..), fail)
import Text.Parsing.Parser.Combinators
import Text.Parsing.Parser.Pos (Position(..), initialPos)
import Text.Parsing.Parser.String (string, oneOf)

-- $doc
-- This is purescript-port of Text.Parsing.Indent
-- https://hackage.haskell.org/package/indents-0.3.3/docs/Text-Parsec-Indent.html, 05.07.2016

-- A module to construct indentation aware parsers. Many programming
-- language have indentation based syntax rules e.g. python and Haskell.
-- This module exports combinators to create such parsers.
--
-- The input source can be thought of as a list of tokens. Abstractly
-- each token occurs at a line and a column and has a width. The column
-- number of a token measures is indentation. If t1 and t2 are two tokens
-- then we say that indentation of t1 is more than t2 if the column
-- number of occurrence of t1 is greater than that of t2.
--
-- Currently this module supports two kind of indentation based syntactic
-- structures which we now describe:
--
-- [Block] --A block of indentation /c/ is a sequence of tokens with
-- indentation at least /c/.  Examples for a block is a where clause of
-- Haskell with no explicit braces.
--
-- [Line fold] A line fold starting at line /l/ and indentation /c/ is a
-- sequence of tokens that start at line /l/ and possibly continue to
-- subsequent lines as long as the indentation is greater than /c/. Such
-- a sequence of lines need to be /folded/ to a single line. An example
-- is MIME headers. Line folding based binding separation is used in
-- Haskell as well.

-- | Indentation sensitive parser type. Usually @ m @ will
--   be @ Identity @ as with any @ ParserT @
type IndentParser s a = ParserT s (State Position) a

-- | @ getPosition @ returns current position
--   should probably be added to Text.Parsing.Parser.Pos
getPosition :: forall m s. (Monad m) => ParserT s m Position
getPosition = ParserT $ \(PState { input: (i :: s), position: (pos :: Position)}) -> return {input: (i :: s), result: (Right (pos :: Position)) :: Either ParseError Position, consumed: false, position: (pos :: Position)}

-- | simple helper function to avoid typ-problems with MonadState instance
get' :: forall s. IndentParser s Position
get' = do
  g <- lift get
  return g

-- | simple helper function to avoid typ-problems with MonadState instance
put' :: forall s. Position -> IndentParser s Unit
put' p = lift (put p)

sourceColumn :: Position -> Int
sourceColumn (Position {line: _, column: c}) = c

sourceLine :: Position -> Int
sourceLine (Position {line: l, column: _}) = l

setSourceLine :: Position -> Int -> Position
setSourceLine (Position {line: _, column: c}) l = Position {line: l, column: c}

biAp :: forall a b c. (a -> b) -> (b -> b -> c) -> a -> a -> c
biAp f c v1 v2 = c (f v1) (f v2)

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

symbol :: forall m. (Monad m) => String -> ParserT String m String
symbol name = (many $ oneOf [' ','\t']) *> (string name)

----------------------------------------------------------------------

-- | @ 'withBlock' f a p @ parses @ a @
--   followed by an indented block of @ p @
--   combining them with @ f @
withBlock :: forall a b c s. (a -> List b -> c) -> IndentParser s a -> IndentParser s b -> IndentParser s c
withBlock f a p = withPos $ do
    r1 <- a
    r  <- optionMaybe $ indented *> block p
    case r of
      Nothing -> return (f r1 Nil)
      Just r2 -> return (f r1 r2)

-- | Like 'withBlock', but throws away initial parse result
withBlock' :: forall a b s. IndentParser s a -> IndentParser s b -> IndentParser s (List b)
withBlock' = withBlock (flip const)

-- | Parses only when indented past the level of the reference
indented :: forall s. IndentParser s Unit
indented = do
    pos <- getPosition
    s <- get'
    if biAp sourceColumn (<=) pos s then fail "not indented" else do
        put' $ setSourceLine s (sourceLine pos)
        return unit

-- | Parses only when indented past the level of the reference or on the same line
sameOrIndented :: forall s. IndentParser s Unit
sameOrIndented = same <|> indented

-- | Parses only on the same line as the reference
same :: forall s. IndentParser s Unit
same = do
    pos <- getPosition
    s   <- get'
    if biAp sourceLine (==) pos s then return unit else fail "over one line"

-- | Parses a block of lines at the same indentation level
block :: forall s a. IndentParser s a -> IndentParser s (List a)
block p = withPos $ do
    r <- many1 $ checkIndent *> p
    return r

-- | Parses using the current location for indentation reference
withPos :: forall s a. IndentParser s a -> IndentParser s a
withPos x = do
    a <- get'
    p <- getPosition
    r <- put' p *> x
    put' a *> return r

-- | Ensures the current indentation level matches that of the reference
checkIndent :: forall s. IndentParser s Unit
checkIndent = do
    s <- get'
    p <- getPosition
    if biAp sourceColumn (==) p s then return unit else fail "indentation doesn't match"

-- | Run the result of an indentation sensitive parse
runIndent :: forall a. State Position a -> a
runIndent = flip evalState initialPos

-- | '<+/>' is to indentation sensitive parsers what 'ap' is to monads
indentAp :: forall s a b. IndentParser s (a -> b) -> IndentParser s a -> IndentParser s b
indentAp a b = ap a $ sameOrIndented *> b

infixl 9 indentAp as <+/>

-- | Like '<+/>' but doesn't apply the function to the parsed value
indentNoAp :: forall s a b. IndentParser s a -> IndentParser s b -> IndentParser s a
indentNoAp a b = lift2 const a $ sameOrIndented *> b

infixl 10 indentNoAp as <-/>

-- | Like '<+/>' but applies the second parser many times
indentMany :: forall s a b. IndentParser s (List a -> b) -> IndentParser s a -> IndentParser s b
indentMany a b = ap a (many (sameOrIndented *> b))

infixl 11 indentMany as <*/>

-- | Datatype used to optional parsing
data Optional s a = Opt a (IndentParser s a)

-- | Like '<+/>' but applies the second parser optionally using the 'Optional' datatype
indentOp :: forall s a b. IndentParser s (a -> b) -> (Optional s a) -> IndentParser s b
indentOp a (Opt b c) = ap a (option b (sameOrIndented *> c))

infixl 12 indentOp as <?/>

-- | parses with surrounding brackets
indentBrackets :: forall a. IndentParser String a -> IndentParser String a
indentBrackets p = withPos $ return id <-/> symbol "[" <+/> p <-/> symbol "]"

-- | parses with surrounding angle brackets
indentAngles :: forall a. IndentParser String a -> IndentParser String a
indentAngles p = withPos $ return id <-/> symbol "<" <+/> p <-/> symbol ">"

-- | parses with surrounding braces
indentBraces :: forall a. IndentParser String a -> IndentParser String a
indentBraces p = withPos $ return id <-/> symbol "{" <+/> p <-/> symbol "}"

-- | parses with surrounding parentheses
indentParens :: forall a. IndentParser String a -> IndentParser String a
indentParens p = withPos $ return id <-/> symbol "(" <+/> p <-/> symbol ")"

error: pathspec 'src/IndentParser.purs' did not match any file(s) known to git


Put 'finally' directly underneath 'later'.

module Control.Monad.Aff
  ( Aff()
  , Canceler(..)
  , PureAff(..)
  , apathize
  , attempt
  , cancel
  , cancelWith
  , forkAff
  , later
  , later'
  , launchAff
  , liftEff'
  , makeAff
  , makeAff'
  , nonCanceler
  , runAff
  )
  where

  import Data.Either(Either(..), either)
  import Data.Function(Fn2(), Fn3(), runFn2, runFn3)
  import Data.Monoid(Monoid, mempty)
  import Control.Apply
  import Control.Alt(Alt)
  import Control.Plus(Plus)
  import Control.Alternative(Alternative)
  import Control.MonadPlus(MonadPlus)
  import Control.Monad.Eff
  import Control.Monad.Eff.Exception(Error(), Exception(), catchException, error)
  import Control.Monad.Eff.Unsafe(unsafeInterleaveEff)
  import Control.Monad.Eff.Class
  import Control.Monad.Error.Class(MonadError, throwError)

  -- | An asynchronous computation with effects `e`. The computation either
  -- | errors or produces a value of type `a`.
  -- |
  -- | This is moral equivalent of `ErrorT (ContT Unit (Eff e)) a`.
  foreign import data Aff :: # ! -> * -> *

  -- | A pure asynchronous computation, having no effects other than
  -- | asynchronous computation.
  type PureAff a = forall e. Aff e a

  -- | A canceler is asynchronous function that can be used to attempt the
  -- | cancelation of a computation. Returns a boolean flag indicating whether
  -- | or not the cancellation was successful. Many computations may be composite,
  -- | in such cases the flag indicates whether any part of the computation was
  -- | successfully canceled. The flag should not be used for communication.
  newtype Canceler e = Canceler (Error -> Aff e Boolean)

  -- | Unwraps the canceler function from the newtype that wraps it.
  cancel :: forall e. Canceler e -> Error ->  Aff e Boolean
  cancel (Canceler f) = f

  -- | This function allows you to attach a custom canceler to an asynchronous
  -- | computation. If the computation is canceled, then the custom canceler
  -- | will be run along side the computation's own canceler.
  cancelWith :: forall e a. Aff e a -> Canceler e -> Aff e a
  cancelWith aff c = runFn3 _cancelWith nonCanceler aff c

  -- | Converts the asynchronous computation into a synchronous one. All values
  -- | and errors are ignored.
  launchAff :: forall e a. Aff e a -> Eff e Unit
  launchAff = runAff (const (pure unit)) (const (pure unit))

  -- | Runs the asynchronous computation. You must supply an error callback and a
  -- | success callback.
  runAff :: forall e a. (Error -> Eff e Unit) -> (a -> Eff e Unit) -> Aff e a -> Eff e Unit
  runAff ex f aff = runFn3 _runAff ex f aff

  -- | Creates an asynchronous effect from a function that accepts error and
  -- | success callbacks. This function can be used for asynchronous computations
  -- | that cannot be canceled.
  makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit) -> Aff e a
  makeAff h = makeAff' (\e a -> const nonCanceler <$> h e a)

  -- | Creates an asynchronous effect from a function that accepts error and
  -- | success callbacks, and returns a canceler for the computation. This
  -- | function can be used for asynchronous computations that can be canceled.
  makeAff' :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a
  makeAff' h = _makeAff h

  -- | Runs the asynchronous computation off the current execution context.
  later :: forall e a. Aff e a -> Aff e a
  later = later' 0

  -- | Runs the specified asynchronous computation later, by the specified
  -- | number of milliseconds.
  later' :: forall e a. Number -> Aff e a -> Aff e a
  later' n aff = runFn3 _setTimeout nonCanceler n aff

  -- | Compute `aff1`, followed by `aff2` regardless of whether `aff1` terminated successfully.
  finally :: forall e a b. Aff e a -> Aff e b -> Aff e a
  finally aff1 aff2 = do
    x <- attempt aff1
    aff2
    either throwError pure x

  -- | Forks the specified asynchronous computation so subsequent computations
  -- | will not block on the result of the computation.
  -- |
  -- | Returns a canceler that can be used to attempt cancellation of the
  -- | forked computation.
  forkAff :: forall e a. Aff e a -> Aff e (Canceler e)
  forkAff aff = runFn2 _forkAff nonCanceler aff

  -- | Promotes any error to the value level of the asynchronous monad.
  attempt :: forall e a. Aff e a -> Aff e (Either Error a)
  attempt aff = runFn3 _attempt Left Right aff

  -- | Ignores any errors.
  apathize :: forall e a. Aff e a -> Aff e Unit
  apathize a = const unit <$> attempt a

  -- | Lifts a synchronous computation and makes explicit any failure from exceptions.
  liftEff' :: forall e a. Eff (err :: Exception | e) a -> Aff e (Either Error a)
  liftEff' eff = attempt (_unsafeInterleaveAff (runFn2 _liftEff nonCanceler eff))

  -- | A constant canceller that always returns false.
  nonCanceler :: forall e. Canceler e
  nonCanceler = Canceler (const (pure false))

  -- | A constant canceller that always returns true.
  alwaysCanceler :: forall e. Canceler e
  alwaysCanceler = Canceler (const (pure true))

  instance semigroupAff :: (Semigroup a) => Semigroup (Aff e a) where
    (<>) a b = (<>) <$> a <*> b

  instance monoidAff :: (Monoid a) => Monoid (Aff e a) where
    mempty = pure mempty

  instance functorAff :: Functor (Aff e) where
    (<$>) f fa = runFn2 _fmap f fa

  instance applyAff :: Apply (Aff e) where
    (<*>) ff fa = runFn3 _bind alwaysCanceler ff (\f -> f <$> fa)

  instance applicativeAff :: Applicative (Aff e) where
    pure v = runFn2 _pure nonCanceler v

  instance bindAff :: Bind (Aff e) where
    (>>=) fa f = runFn3 _bind alwaysCanceler fa f

  instance monadAff :: Monad (Aff e)

  instance monadEffAff :: MonadEff e (Aff e) where
    liftEff eff = runFn2 _liftEff nonCanceler eff

  -- | Allows users to catch and throw errors on the error channel of the
  -- | asynchronous computation. See documentation in `purescript-transformers`.
  instance monadErrorAff :: MonadError Error (Aff e) where
    throwError e = runFn2 _throwError nonCanceler e

    catchError aff ex = attempt aff >>= either ex pure

  instance altAff :: Alt (Aff e) where
    (<|>) a1 a2 = attempt a1 >>= either (const a2) pure

  instance plusAff :: Plus (Aff e) where
    empty = throwError $ error "Always fails"

  instance alternativeAff :: Alternative (Aff e)

  instance monadPlusAff :: MonadPlus (Aff e)

  instance semigroupCanceler :: Semigroup (Canceler e) where
    (<>) (Canceler f1) (Canceler f2) = Canceler (\e -> (||) <$> f1 e <*> f2 e)

  instance monoidCanceler :: Monoid (Canceler e) where
    mempty = Canceler (const (pure true))

  foreign import _cancelWith """
    function _cancelWith(nonCanceler, aff, canceler1) {
      return function(success, error) {
        var canceler2 = aff(success, error);

        return function(e) {
          return function(success, error) {
            var cancellations = 0;
            var result        = false;
            var errored       = false;

            var s = function(bool) {
              cancellations = cancellations + 1;
              result        = result || bool;

              if (cancellations === 2 && !errored) {
                try {
                  success(result);
                } catch (e) {
                  error(e);
                }
              }
            };

            var f = function(err) {
              if (!errored) {
                errored = true;

                error(err);
              }
            };

            canceler2(e)(s, f);
            canceler1(e)(s, f);

            return nonCanceler;
          };
        };
      };
    }
  """ :: forall e a. Fn3 (Canceler e) (Aff e a) (Canceler e) (Aff e a)

  foreign import _setTimeout """
    function _setTimeout(nonCanceler, millis, aff) {
      return function(success, error) {
        var canceler;

        var timeout = setTimeout(function() {
          canceler = aff(success, error);
        }, millis);

        return function(e) {
          return function(s, f) {
            if (canceler !== undefined) {
              return canceler(e)(s, f);
            } else {
              clearTimeout(timeout);

              try {
                s(true);
              } catch (e) {
                f(e);
              }

              return nonCanceler;
            }
          };
        };
      };
    }
  """ :: forall e a. Fn3 (Canceler e) Number (Aff e a) (Aff e a)

  foreign import _unsafeInterleaveAff """
    function _unsafeInterleaveAff(aff) {
      return aff;
    }
  """ :: forall e1 e2 a. Aff e1 a -> Aff e2 a

  foreign import _forkAff """
    function _forkAff(nonCanceler, aff) {
      var voidF = function(){};

      return function(success, error) {
        var canceler = aff(voidF, voidF);

        try {
          success(canceler);
        } catch (e) {
          error(e);
        }

        return nonCanceler;
      };
    }
  """ :: forall e a. Fn2 (Canceler e) (Aff e a) (Aff e (Canceler e))

  foreign import _makeAff """
    function _makeAff(cb) {
      return function(success, error) {
        return cb(function(e) {
          return function() {
            error(e);
          };
        })(function(v) {
          return function() {
            try {
              success(v);
            } catch (e) {
              error(e);
            }
          };
        })();
      }
    }
    """ :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a

  foreign import _pure """
    function _pure(nonCanceler, v) {
      return function(success, error) {
        try {
          success(v);
        } catch (e) {
          error(e);
        }

        return nonCanceler;
      }
    }""" :: forall e a. Fn2 (Canceler e) a (Aff e a)

  foreign import _throwError """
    function _throwError(nonCanceler, e) {
      return function(success, error) {
        error(e);

        return nonCanceler;
      };
    }""" :: forall e a. Fn2 (Canceler e) Error (Aff e a)

  foreign import _fmap """
    function _fmap(f, aff) {
      return function(success, error) {
        return aff(function(v) {
          try {
            success(f(v));
          } catch (e) {
            error(e);
          }
        }, error);
      };
    }""" :: forall e a b. Fn2 (a -> b) (Aff e a) (Aff e b)

  foreign import _bind """
    function _bind(alwaysCanceler, aff, f) {
      return function(success, error) {
        var canceler1, canceler2;

        var isCanceled    = false;
        var requestCancel = false;

        var onCanceler = function(){};

        canceler1 = aff(function(v) {
          if (requestCancel) {
            isCanceled = true;

            return alwaysCanceler;
          } else {
            canceler2 = f(v)(success, error);

            onCanceler(canceler2);

            return canceler2;
          }
        }, error);

        return function(e) {
          return function(s, f) {
            requestCancel = true;

            if (canceler2 !== undefined) {
              return canceler2(e)(s, f);
            } else {
              return canceler1(e)(function(bool) {
                if (bool || isCanceled) {
                  try {
                    s(true);
                  } catch (e) {
                    f(e);
                  }
                } else {
                  onCanceler = function(canceler) {
                    canceler(e)(s, f);
                  };
                }
              }, f);
            }
          };
        };
      };
    }""" :: forall e a b. Fn3 (Canceler e) (Aff e a) (a -> Aff e b) (Aff e b)

  foreign import _attempt """
    function _attempt(Left, Right, aff) {
      return function(success, error) {
        return aff(function(v) {
          try {
            success(Right(v));
          } catch (e) {
            error(e);
          }
        }, function(e) {
          try {
            success(Left(e));
          } catch (e) {
            error(e);
          }
        });
      };
    }"""  :: forall e a. Fn3 (forall x y. x -> Either x y) (forall x y. y -> Either x y) (Aff e a) (Aff e (Either Error a))

  foreign import _runAff """
    function _runAff(errorT, successT, aff) {
      return function() {
        return aff(function(v) {
          try {
            successT(v)();
          } catch (e) {
            errorT(e)();
          }
        }, function(e) {
          errorT(e)();
        });
      };
    }""" :: forall e a. Fn3 (Error -> Eff e Unit) (a -> Eff e Unit) (Aff e a) (Eff e Unit)

  foreign import _liftEff """
    function _liftEff(nonCanceler, e) {
      return function(success, error) {
        try {
          success(e());
        } catch (e) {
          error(e);
        }

        return nonCanceler;
      };
    }""" :: forall e a. Fn2 (Canceler e) (Eff e a) (Aff e a)

module Control.Monad.Aff
  ( Aff()
  , Canceler(..)
  , PureAff(..)
  , apathize
  , attempt
  , cancel
  , cancelWith
  , forkAff
  , later
  , later'
  , launchAff
  , liftEff'
  , makeAff
  , makeAff'
  , nonCanceler
  , runAff
  )
  where

  import Data.Either(Either(..), either)
  import Data.Function(Fn2(), Fn3(), runFn2, runFn3)
  import Data.Monoid(Monoid, mempty)
  import Control.Apply
  import Control.Alt(Alt)
  import Control.Plus(Plus)
  import Control.Alternative(Alternative)
  import Control.MonadPlus(MonadPlus)
  import Control.Monad.Eff
  import Control.Monad.Eff.Exception(Error(), Exception(), catchException, error)
  import Control.Monad.Eff.Unsafe(unsafeInterleaveEff)
  import Control.Monad.Eff.Class
  import Control.Monad.Error.Class(MonadError, throwError)

  -- | An asynchronous computation with effects `e`. The computation either
  -- | errors or produces a value of type `a`.
  -- |
  -- | This is moral equivalent of `ErrorT (ContT Unit (Eff e)) a`.
  foreign import data Aff :: # ! -> * -> *

  -- | A pure asynchronous computation, having no effects other than
  -- | asynchronous computation.
  type PureAff a = forall e. Aff e a

  -- | A canceler is asynchronous function that can be used to attempt the
  -- | cancelation of a computation. Returns a boolean flag indicating whether
  -- | or not the cancellation was successful. Many computations may be composite,
  -- | in such cases the flag indicates whether any part of the computation was
  -- | successfully canceled. The flag should not be used for communication.
  newtype Canceler e = Canceler (Error -> Aff e Boolean)

  -- | Unwraps the canceler function from the newtype that wraps it.
  cancel :: forall e. Canceler e -> Error ->  Aff e Boolean
  cancel (Canceler f) = f

  -- | This function allows you to attach a custom canceler to an asynchronous
  -- | computation. If the computation is canceled, then the custom canceler
  -- | will be run along side the computation's own canceler.
  cancelWith :: forall e a. Aff e a -> Canceler e -> Aff e a
  cancelWith aff c = runFn3 _cancelWith nonCanceler aff c

  -- | Converts the asynchronous computation into a synchronous one. All values
  -- | and errors are ignored.
  launchAff :: forall e a. Aff e a -> Eff e Unit
  launchAff = runAff (const (pure unit)) (const (pure unit))

  -- | Runs the asynchronous computation. You must supply an error callback and a
  -- | success callback.
  runAff :: forall e a. (Error -> Eff e Unit) -> (a -> Eff e Unit) -> Aff e a -> Eff e Unit
  runAff ex f aff = runFn3 _runAff ex f aff

  -- | Creates an asynchronous effect from a function that accepts error and
  -- | success callbacks. This function can be used for asynchronous computations
  -- | that cannot be canceled.
  makeAff :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e Unit) -> Aff e a
  makeAff h = makeAff' (\e a -> const nonCanceler <$> h e a)

  -- | Creates an asynchronous effect from a function that accepts error and
  -- | success callbacks, and returns a canceler for the computation. This
  -- | function can be used for asynchronous computations that can be canceled.
  makeAff' :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a
  makeAff' h = _makeAff h

  -- | Runs the asynchronous computation off the current execution context.
  later :: forall e a. Aff e a -> Aff e a
  later = later' 0

  -- | Runs the specified asynchronous computation later, by the specified
  -- | number of milliseconds.
  later' :: forall e a. Number -> Aff e a -> Aff e a
  later' n aff = runFn3 _setTimeout nonCanceler n aff

  -- | Forks the specified asynchronous computation so subsequent computations
  -- | will not block on the result of the computation.
  -- |
  -- | Returns a canceler that can be used to attempt cancellation of the
  -- | forked computation.
  forkAff :: forall e a. Aff e a -> Aff e (Canceler e)
  forkAff aff = runFn2 _forkAff nonCanceler aff

  -- | Promotes any error to the value level of the asynchronous monad.
  attempt :: forall e a. Aff e a -> Aff e (Either Error a)
  attempt aff = runFn3 _attempt Left Right aff

  -- | Ignores any errors.
  apathize :: forall e a. Aff e a -> Aff e Unit
  apathize a = const unit <$> attempt a

  -- | Compute `aff1`, followed by `aff2` regardless of whether `aff1` terminated successfully.
  finally :: forall e a b. Aff e a -> Aff e b -> Aff e a
  finally aff1 aff2 = do
    x <- attempt aff1
    aff2
    either throwError pure x

  -- | Lifts a synchronous computation and makes explicit any failure from exceptions.
  liftEff' :: forall e a. Eff (err :: Exception | e) a -> Aff e (Either Error a)
  liftEff' eff = attempt (_unsafeInterleaveAff (runFn2 _liftEff nonCanceler eff))

  -- | A constant canceller that always returns false.
  nonCanceler :: forall e. Canceler e
  nonCanceler = Canceler (const (pure false))

  -- | A constant canceller that always returns true.
  alwaysCanceler :: forall e. Canceler e
  alwaysCanceler = Canceler (const (pure true))

  instance semigroupAff :: (Semigroup a) => Semigroup (Aff e a) where
    (<>) a b = (<>) <$> a <*> b

  instance monoidAff :: (Monoid a) => Monoid (Aff e a) where
    mempty = pure mempty

  instance functorAff :: Functor (Aff e) where
    (<$>) f fa = runFn2 _fmap f fa

  instance applyAff :: Apply (Aff e) where
    (<*>) ff fa = runFn3 _bind alwaysCanceler ff (\f -> f <$> fa)

  instance applicativeAff :: Applicative (Aff e) where
    pure v = runFn2 _pure nonCanceler v

  instance bindAff :: Bind (Aff e) where
    (>>=) fa f = runFn3 _bind alwaysCanceler fa f

  instance monadAff :: Monad (Aff e)

  instance monadEffAff :: MonadEff e (Aff e) where
    liftEff eff = runFn2 _liftEff nonCanceler eff

  -- | Allows users to catch and throw errors on the error channel of the
  -- | asynchronous computation. See documentation in `purescript-transformers`.
  instance monadErrorAff :: MonadError Error (Aff e) where
    throwError e = runFn2 _throwError nonCanceler e

    catchError aff ex = attempt aff >>= either ex pure

  instance altAff :: Alt (Aff e) where
    (<|>) a1 a2 = attempt a1 >>= either (const a2) pure

  instance plusAff :: Plus (Aff e) where
    empty = throwError $ error "Always fails"

  instance alternativeAff :: Alternative (Aff e)

  instance monadPlusAff :: MonadPlus (Aff e)

  instance semigroupCanceler :: Semigroup (Canceler e) where
    (<>) (Canceler f1) (Canceler f2) = Canceler (\e -> (||) <$> f1 e <*> f2 e)

  instance monoidCanceler :: Monoid (Canceler e) where
    mempty = Canceler (const (pure true))

  foreign import _cancelWith """
    function _cancelWith(nonCanceler, aff, canceler1) {
      return function(success, error) {
        var canceler2 = aff(success, error);

        return function(e) {
          return function(success, error) {
            var cancellations = 0;
            var result        = false;
            var errored       = false;

            var s = function(bool) {
              cancellations = cancellations + 1;
              result        = result || bool;

              if (cancellations === 2 && !errored) {
                try {
                  success(result);
                } catch (e) {
                  error(e);
                }
              }
            };

            var f = function(err) {
              if (!errored) {
                errored = true;

                error(err);
              }
            };

            canceler2(e)(s, f);
            canceler1(e)(s, f);

            return nonCanceler;
          };
        };
      };
    }
  """ :: forall e a. Fn3 (Canceler e) (Aff e a) (Canceler e) (Aff e a)

  foreign import _setTimeout """
    function _setTimeout(nonCanceler, millis, aff) {
      return function(success, error) {
        var canceler;

        var timeout = setTimeout(function() {
          canceler = aff(success, error);
        }, millis);

        return function(e) {
          return function(s, f) {
            if (canceler !== undefined) {
              return canceler(e)(s, f);
            } else {
              clearTimeout(timeout);

              try {
                s(true);
              } catch (e) {
                f(e);
              }

              return nonCanceler;
            }
          };
        };
      };
    }
  """ :: forall e a. Fn3 (Canceler e) Number (Aff e a) (Aff e a)

  foreign import _unsafeInterleaveAff """
    function _unsafeInterleaveAff(aff) {
      return aff;
    }
  """ :: forall e1 e2 a. Aff e1 a -> Aff e2 a

  foreign import _forkAff """
    function _forkAff(nonCanceler, aff) {
      var voidF = function(){};

      return function(success, error) {
        var canceler = aff(voidF, voidF);

        try {
          success(canceler);
        } catch (e) {
          error(e);
        }

        return nonCanceler;
      };
    }
  """ :: forall e a. Fn2 (Canceler e) (Aff e a) (Aff e (Canceler e))

  foreign import _makeAff """
    function _makeAff(cb) {
      return function(success, error) {
        return cb(function(e) {
          return function() {
            error(e);
          };
        })(function(v) {
          return function() {
            try {
              success(v);
            } catch (e) {
              error(e);
            }
          };
        })();
      }
    }
    """ :: forall e a. ((Error -> Eff e Unit) -> (a -> Eff e Unit) -> Eff e (Canceler e)) -> Aff e a

  foreign import _pure """
    function _pure(nonCanceler, v) {
      return function(success, error) {
        try {
          success(v);
        } catch (e) {
          error(e);
        }

        return nonCanceler;
      }
    }""" :: forall e a. Fn2 (Canceler e) a (Aff e a)

  foreign import _throwError """
    function _throwError(nonCanceler, e) {
      return function(success, error) {
        error(e);

        return nonCanceler;
      };
    }""" :: forall e a. Fn2 (Canceler e) Error (Aff e a)

  foreign import _fmap """
    function _fmap(f, aff) {
      return function(success, error) {
        return aff(function(v) {
          try {
            success(f(v));
          } catch (e) {
            error(e);
          }
        }, error);
      };
    }""" :: forall e a b. Fn2 (a -> b) (Aff e a) (Aff e b)

  foreign import _bind """
    function _bind(alwaysCanceler, aff, f) {
      return function(success, error) {
        var canceler1, canceler2;

        var isCanceled    = false;
        var requestCancel = false;

        var onCanceler = function(){};

        canceler1 = aff(function(v) {
          if (requestCancel) {
            isCanceled = true;

            return alwaysCanceler;
          } else {
            canceler2 = f(v)(success, error);

            onCanceler(canceler2);

            return canceler2;
          }
        }, error);

        return function(e) {
          return function(s, f) {
            requestCancel = true;

            if (canceler2 !== undefined) {
              return canceler2(e)(s, f);
            } else {
              return canceler1(e)(function(bool) {
                if (bool || isCanceled) {
                  try {
                    s(true);
                  } catch (e) {
                    f(e);
                  }
                } else {
                  onCanceler = function(canceler) {
                    canceler(e)(s, f);
                  };
                }
              }, f);
            }
          };
        };
      };
    }""" :: forall e a b. Fn3 (Canceler e) (Aff e a) (a -> Aff e b) (Aff e b)

  foreign import _attempt """
    function _attempt(Left, Right, aff) {
      return function(success, error) {
        return aff(function(v) {
          try {
            success(Right(v));
          } catch (e) {
            error(e);
          }
        }, function(e) {
          try {
            success(Left(e));
          } catch (e) {
            error(e);
          }
        });
      };
    }"""  :: forall e a. Fn3 (forall x y. x -> Either x y) (forall x y. y -> Either x y) (Aff e a) (Aff e (Either Error a))

  foreign import _runAff """
    function _runAff(errorT, successT, aff) {
      return function() {
        return aff(function(v) {
          try {
            successT(v)();
          } catch (e) {
            errorT(e)();
          }
        }, function(e) {
          errorT(e)();
        });
      };
    }""" :: forall e a. Fn3 (Error -> Eff e Unit) (a -> Eff e Unit) (Aff e a) (Eff e Unit)

  foreign import _liftEff """
    function _liftEff(nonCanceler, e) {
      return function(success, error) {
        try {
          success(e());
        } catch (e) {
          error(e);
        }

        return nonCanceler;
      };
    }""" :: forall e a. Fn2 (Canceler e) (Eff e a) (Aff e a)


4.11.2

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/mikemcgowan/purescript-book.git/'


Make sure argument names can not be parsed as units

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( DictEntry(..)
  , (==>)
  , Dictionary(..)
  , commands
  , prefixDict
  , normalUnitDict
  , imperialUnitDict
  , parseInsect
  ) where

import Prelude hiding (degree)

import Control.Alt ((<|>))
import Control.Lazy (fix)

import Quantities (DerivedUnit, (./))
import Quantities as Q

import Data.Array (some, fromFoldable)
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Either (Either, isRight)
import Data.Foldable (foldr, traverse_)
import Data.Foldable as F
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.StrMap (lookup)
import Data.String (fromCharArray, singleton)

import Text.Parsing.Parser (ParserT, Parser, ParseError, runParser, fail)
import Text.Parsing.Parser.Combinators (option, optionMaybe, try, (<?>),
                                        notFollowedBy)
import Text.Parsing.Parser.String (string, char, eof, oneOf)
import Text.Parsing.Parser.Token (GenLanguageDef(..), LanguageDef, TokenParser,
                                  digit, letter, makeTokenParser)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..),
                        Identifier)
import Insect.Environment (Environment, StoredFunction(..))

-- | A type synonym for the main Parser type with `String` as input.
type P a = Parser String a

-- | Possible characters for the first character of an identifier.
identStart ∷ P Char
identStart = letter <|> char '_'

-- | Possible characters for identifiers (not for the first character).
identLetter ∷ P Char
identLetter = letter <|> digit <|> char '_' <|> char '\''

-- | A list of allowed commands
commands ∷ Array String
commands = ["help", "?", "list", "ls", "ll", "reset", "clear", "cls", "quit", "exit"]

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: identStart
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '⋅', '×', '/', '÷', '%', '^', '!', '→', '➞', '=']
  , opLetter: oneOf []
  , reservedNames: commands <> ["¹", "²", "³", "⁴", "⁵", "⁻¹", "⁻²", "⁻³", "⁻⁴", "⁻⁵", "to", "per"]
  , reservedOpNames: ["->", "+", "-", "*", "·", "⋅", "×", "/", "÷", "%", "^", "!",
                      "**", "=", ","]
  , caseSensitive: true
}

-- | The actual token parser.
token ∷ TokenParser
token = makeTokenParser insectLanguage

-- | Parse something, inside of parens.
parens ∷ ∀ a. P a → P a
parens = token.parens

-- | Parse one of the reserved operators.
reservedOp ∷ String → P Unit
reservedOp = token.reservedOp

-- | Parse a reserverd keyword.
reserved ∷ String → P Unit
reserved = token.reserved

-- | Parse zero or more whitespace characters.
whiteSpace ∷ P Unit
whiteSpace = token.whiteSpace

-- | Parse a number.
number ∷ P Decimal
number = do
  intPart ← digits

  mFracPart ← optionMaybe (append <$> string "." <*> digits)
  let fracPart = fromMaybe "" mFracPart

  mExpPart ← optionMaybe $ try do
    _ ← string "e"
    notFollowedBy identStart
    sad ← signAndDigits
    pure ("e" <> sad)
  let expPart = fromMaybe "" mExpPart

  whiteSpace

  let floatStr = intPart <> fracPart <> expPart

  case fromString floatStr of
    Just num →
      if isFinite num
      then pure num
      else fail "This number is too large"
    Nothing → fail $ "Parsing of number failed for input '" <> floatStr <> "'"

  where
    digits ∷ P String
    digits = do
      ds ← some $ oneOf ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'] <?> "a digit"
      pure $ fromCharArray (fromFoldable ds)

    signAndDigits ∷ P String
    signAndDigits = do
      sign ← option '+' (oneOf ['+', '-'])
      intPart ← digits
      pure $ singleton sign <> intPart

-- | A helper type for entries in the dictionary.
data DictEntry a = DictEntry a (Array String)

infix 4 DictEntry as ==>

-- | A dictionary of units and their abbreviations.
data Dictionary a = Dictionary (Array (DictEntry a))

-- | Build a parser from a Dictionary
buildDictParser ∷ ∀ a. Dictionary a → P a
buildDictParser (Dictionary dict) = F.oneOf $ entryParser <$> dict
  where
    entryParser (x ==> abbrevs) = F.oneOf $ abbrevParser x <$> abbrevs
    abbrevParser x abbrev = string abbrev *> pure x

prefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
prefixDict = Dictionary
  [ Q.kibi ==> ["kibi", "Ki"]
  , Q.mebi ==> ["mebi", "Mi"]
  , Q.gibi ==> ["gibi", "Gi"]
  , Q.tebi ==> ["tebi", "Ti"]
  , Q.pebi ==> ["pebi", "Pi"]
  , Q.exbi ==> ["exbi", "Ei"]
  , Q.zebi ==> ["zebi", "Zi"]
  , Q.yobi ==> ["yobi", "Yi"]
  , Q.atto ==> ["atto", "a"]
  , Q.femto ==> ["femto", "f"]
  -- peta and mega have to be up here (before pico and milli) in order for the
  -- prefixes ('p' and 'm') not to be parsed as 'pico' or 'milli'.
  , Q.peta ==> ["peta"]
  , Q.mega ==> ["mega"]
  , Q.pico ==> ["pico", "p"]
  , Q.nano ==> ["nano", "n"]
  , Q.micro ==> [ "micro"
                , "u" -- u for micro
                , "µ" -- Micro sign U+00B5
                , "μ" -- Greek small letter mu U+039C
                ]
  , Q.milli ==> ["milli", "m"]
  , Q.centi ==> ["centi", "c"]
  , Q.deci ==> ["deci", "d"]
  , Q.hecto ==> ["hecto", "h"]
  , Q.kilo ==> ["kilo", "k"]
  , Q.mega ==> ["M"]
  , Q.giga ==> ["giga", "G"]
  , Q.tera ==> ["tera", "T"]
  , Q.peta ==> ["P"]
  , Q.exa ==> ["exa", "E"]
  ]

-- | Parse a SI or IEC prefix like `µ`, `G`, `pico` or `Ki`.
prefix ∷ P (DerivedUnit → DerivedUnit)
prefix = buildDictParser prefixDict <|> pure id

-- | Normal (SI-conform, non-imperial) units
normalUnitDict ∷ Dictionary DerivedUnit
normalUnitDict = Dictionary
  [ Q.radian ==> ["radians", "radian", "rad"]
  , Q.degree ==> ["degrees", "degree", "deg", "°"]
  , Q.hertz ==> ["hertz", "Hz"]
  , Q.rpm ==> ["RPM", "rpm"]
  , Q.newton ==> ["newton", "N"]
  , Q.joule ==> ["joules", "joule", "J"]
  , Q.pascal ==> ["pascal", "Pa"]
  , Q.volt ==> ["volts", "volt", "V"]
  , Q.farad ==> ["farad", "F"]
  , Q.ohm ==> ["ohms", "ohm", "Ω"]
  , Q.sievert ==> ["sievert", "Sv"]
  , Q.weber ==> ["weber", "Wb"]
  , Q.tesla ==> ["tesla", "T"]
  , Q.henry ==> ["henry", "H"]
  , Q.coulomb ==> ["coulomb", "C"]
  , Q.siemens ==> ["siemens", "S"]
  , Q.lumen ==> ["lumen", "lm"]
  , Q.lux ==> ["lux", "lx"]
  , Q.becquerel ==> ["becquerel", "Bq"]
  , Q.gray ==> ["gray", "Gy"]
  , Q.katal ==> ["katal", "kat"]
  , Q.hectare ==> ["hectare", "ha"]
  , Q.tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , Q.electronvolt ==> ["electronvolt", "eV"]
  , Q.calorie ==> ["calories", "calorie", "cal"]
  , Q.bel ==> ["bel"]
  , Q.astronomicalUnit ==> ["AU"]
  , Q.parsec ==> ["parsecs", "parsec", "pc"]
  , Q.lightyear ==> ["lightyears", "lightyear", "ly"]
  , Q.barn ==> ["barn"]
  , Q.bar ==> ["bar"]
  , Q.angstrom ==> ["angstrom", "Å"]
  , Q.gauss ==> ["gauss"]
  , Q.ampere ==> ["amperes", "ampere", "A"]
  , Q.mole ==> ["mole", "mol"]
  , Q.kelvin ==> ["kelvin", "K"]
  , Q.candela ==> ["candela", "cd"]
  , Q.watt <> Q.hour ==> ["Wh"]
  , Q.watt ==> ["watts", "watt", "W"]
  , Q.byte ==> ["Bytes", "bytes", "Byte", "byte", "B", "Octets", "octets", "Octet", "octet"]
  , Q.bit ==> ["bits", "bit"]
  , Q.bit ./ Q.second ==> ["bps"]
  , Q.second ==> ["seconds", "second", "sec", "s"]
  , Q.minute ==> ["minutes", "minute", "min"]
  , Q.hour ==> ["hours", "hour", "h"]
  , Q.day ==> ["days", "day"]
  , Q.week ==> ["weeks", "week"]
  , Q.fortnight ==> ["fortnights", "fortnight"]
  , Q.month ==> ["months", "month"]
  , Q.year ==> ["years", "year"]
  , Q.gram ==> ["grammes", "gramme", "grams", "gram", "g"]
  , Q.meter ==> ["metres", "metre", "meters", "meter", "m"]
  , Q.liter ==> ["liters", "liter", "litres", "litre", "L", "l"]
  , Q.atm ==> ["atm"]
  ]

-- | Parse a normal (SI-conform, non-imperical) unit, like `N` or `watt`.
normalUnit ∷ P DerivedUnit
normalUnit = buildDictParser normalUnitDict <?> "normal unit"

-- | Imperial units
imperialUnitDict ∷ Dictionary DerivedUnit
imperialUnitDict = Dictionary
  [ Q.mile ==> ["miles", "mile"]
  , Q.mile ./ Q.hour ==> ["mph"]
  , Q.inch ==> ["inches", "inch", "in"]
  , Q.yard ==> ["yards", "yard", "yd"]
  , Q.foot ==> ["feet", "foot", "ft"]
  , Q.ounce ==> ["ounces", "ounce", "oz"]
  , Q.pound ==> ["pounds", "pound", "lb"]
  , Q.gallon ==> ["gallons", "gallon", "gal"]
  , Q.pint ==> ["pints", "pint"]
  , Q.cup ==> ["cups", "cup"]
  , Q.tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , Q.teaspoon ==> ["teaspoons", "teaspoon", "tsp"]
  , Q.fluidounce ==> ["fluidounces", "fluidounce", "floz"]
  , Q.furlong ==> ["furlong"]
  , Q.btu ==> ["BTU"]
  , Q.psi ==> ["psi"]
  , Q.mmHg ==> ["mmHg"]
  , Q.hogshead ==> ["hogsheads", "hogshead"]
  , Q.rod ==> ["rods", "rod"]
  ]

-- | Parse an imperial unit like `ft` of `mile`.
imperialUnit ∷ P DerivedUnit
imperialUnit = buildDictParser imperialUnitDict <?> "imperial unit"

-- | Parse a 'normal' unit with SI prefix, like `km` or `Gb`.
unitWithSIPrefix ∷ P DerivedUnit
unitWithSIPrefix = do
  p ← prefix
  u ← normalUnit
  pure $ p u

specialCases ∷ P DerivedUnit
specialCases =
  -- The abbreviation 'd' for 'day' needs to be treated separately. Otherwise,
  -- 'cd' will be parsed as 'centi day' instead of 'candela'.
      string "d" *> pure Q.day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure Q.tonne

-- | Parse a derived unit, like `km`, `ft`, or `s`.
derivedUnit ∷ P DerivedUnit
derivedUnit =
  (
        try (augment unitWithSIPrefix)
    <|> augment imperialUnit
    <|> augment normalUnit
    <|> augment specialCases
  ) <* whiteSpace
  where
    augment p = p <* notFollowedBy identLetter

-- | Parse the name of a variable, like `my_variable'`.
variable ∷ P Expression
variable = Variable <$> token.identifier

-- | A version of `sepBy1` that returns a `NonEmpty List`.
sepBy1 ∷ ∀ m s a sep. Monad m ⇒ ParserT s m a → ParserT s m sep → ParserT s m (NonEmpty List a)
sepBy1 p sep = do
  a ← p
  as ← many $ sep *> p
  pure (a :| as)

-- | Fold a non-empty structure, collecting results using a binary operation.
foldr1 ∷ ∀ a. (a → a → a) → NonEmpty List a → a
foldr1 f (a :| xs) =
  case init xs, last xs of
    Just bs, Just b → f a (foldr f b bs)
    _, _ → a

-- | Parse a function name and fail if it's not in the environment
function ∷ Environment → P Identifier
function env = do
  name ← token.identifier
  case lookup name env.functions of
    Just (StoredFunction _ fn) → pure name
    Nothing → fail ("Unknown function '" <> name <> "'")

-- | Parse a full mathematical expression.
expression ∷ Environment → P Expression
expression env =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> function env <*> parens (sepBy1 p commaOp))
          <|> variable
          )

      suffixFac ∷ P Expression
      suffixFac = do
        a ← atomic
        mf ← optionMaybe (facOp *> pure Factorial)
        case mf of
          Just f → pure $ f a
          Nothing → pure a

      suffixPow ∷ P Expression
      suffixPow = do
        x ← suffixFac
        mFn ← optionMaybe (     reservedOp "¹" *>  pure (powPos 1.0)
                            <|> reservedOp "²" *>  pure (powPos 2.0)
                            <|> reservedOp "³" *>  pure (powPos 3.0)
                            <|> reservedOp "⁴" *>  pure (powPos 4.0)
                            <|> reservedOp "⁵" *>  pure (powPos 5.0)
                            <|> reservedOp "⁻¹" *> pure (powNeg 1.0)
                            <|> reservedOp "⁻²" *> pure (powNeg 2.0)
                            <|> reservedOp "⁻³" *> pure (powNeg 3.0)
                            <|> reservedOp "⁻⁴" *> pure (powNeg 4.0)
                            <|> reservedOp "⁻⁵" *> pure (powNeg 5.0)
                          )
        case mFn of
          Just fn → pure $ fn x
          Nothing → pure x

      sepByPow ∷ P Expression
      sepByPow = foldr1 (BinOp Pow) <$> suffixPow `sepBy1` powOp

      sepByMulImplicit ∷ P Expression
      sepByMulImplicit = foldl1 (BinOp Mul) <$> sepByPow `sepBy1` pure unit

      sepByMod ∷ P Expression
      sepByMod = foldl1 (BinOp Mod) <$> sepByMulImplicit `sepBy1` modOp

      sepByDiv ∷ P Expression
      sepByDiv = foldl1 (BinOp Div) <$> sepByMod `sepBy1` divOp

      sepByMul ∷ P Expression
      sepByMul = foldl1 (BinOp Mul) <$> sepByDiv `sepBy1` mulOp

      prefixed ∷ P Expression
      prefixed = do
        prefixFn ← ((subOp *> pure Negate) <|> (addOp *> pure id) <|> pure id)
        prefixFn <$> sepByMul

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> prefixed `sepBy1` subOp

      sepByAdd ∷ P Expression
      sepByAdd = foldl1 (BinOp Add) <$> sepBySub `sepBy1` addOp

      sepByConv ∷ P Expression
      sepByConv = foldl1 (BinOp ConvertTo) <$> sepByAdd `sepBy1` arrOp

    in sepByConv

  where

    commaOp = reservedOp ","
    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    modOp = reservedOp "%"
    divOp = reservedOp "/" <|> reservedOp "÷" <|> reserved "per"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reservedOp "➞" <|> reserved "to"

    powPos s q | s == 1.0  = q
               | otherwise = BinOp Pow q (Scalar $ fromNumber s)
    powNeg s q = BinOp Pow q (Negate $ Scalar $ fromNumber s)

-- | Parse a mathematical expression (or conversion) like `3m+2in -> cm`.
fullExpression ∷ Environment → P Expression
fullExpression env = do
  whiteSpace
  expr ← expression env
  eof <?> "end of input"

  pure $ expr

-- | Parse an Insect command.
command ∷ P Command
command =
  (
        (reserved "help" <|> reserved "?") *> pure Help
    <|> (reserved "list" <|> reserved "ls" <|> reserved "ll") *> pure List
    <|> (reserved "reset") *> pure Reset
    <|> (reserved "clear" <|> reserved "cls") *> pure Clear
    <|> (reserved "quit" <|> reserved "exit") *> pure Quit
  ) <* eof

-- | Parse a variable- or function assignment.
assignment ∷ Environment → P Statement
assignment env = do
  { name, args, expr } ←
    try do
      whiteSpace
      name ← token.identifier
      args ← optionMaybe (parens (sepBy1 token.identifier (reservedOp ",")))
      reservedOp "="
      expr ← expression env
      eof

      pure { name: name, args: args, expr: expr }

  -- Fail if the name can be parsed as a physical unit
  failIfUnit name

  case args of
    Nothing → pure (VariableAssignment name expr)
    Just xs → do
      traverse_ failIfUnit xs
      pure (FunctionAssignment name xs expr)

  where
    failIfUnit n =
      when (isRight $ runParser n (derivedUnit <* eof)) $
        fail ("'" <> n <> "' is reserved for a physical unit")

-- | Parse a statement in the Insect language.
statement ∷ Environment → P Statement
statement env =
      (Command <$> command)
  <|> assignment env
  <|> (Expression <$> fullExpression env)

-- | Run the Insect-parser on a `String` input.
parseInsect ∷ Environment → String → Either ParseError Statement
parseInsect env inp = runParser inp (statement env)

-- | This module defines the parser for the Insect language.
module Insect.Parser
  ( DictEntry(..)
  , (==>)
  , Dictionary(..)
  , commands
  , prefixDict
  , normalUnitDict
  , imperialUnitDict
  , parseInsect
  ) where

import Prelude hiding (degree)

import Control.Alt ((<|>))
import Control.Lazy (fix)

import Quantities (DerivedUnit, (./))
import Quantities as Q

import Data.Array (some, fromFoldable)
import Data.Decimal (Decimal, fromString, fromNumber, isFinite)
import Data.Either (Either, isRight)
import Data.Foldable (foldr)
import Data.Foldable as F
import Data.List (List, many, init, last)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.NonEmpty (NonEmpty, (:|), foldl1)
import Data.StrMap (lookup)
import Data.String (fromCharArray, singleton)

import Text.Parsing.Parser (ParserT, Parser, ParseError, runParser, fail)
import Text.Parsing.Parser.Combinators (option, optionMaybe, try, (<?>),
                                        notFollowedBy)
import Text.Parsing.Parser.String (string, char, eof, oneOf)
import Text.Parsing.Parser.Token (GenLanguageDef(..), LanguageDef, TokenParser,
                                  digit, letter, makeTokenParser)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..),
                        Identifier)
import Insect.Environment (Environment, StoredFunction(..))

-- | A type synonym for the main Parser type with `String` as input.
type P a = Parser String a

-- | Possible characters for the first character of an identifier.
identStart ∷ P Char
identStart = letter <|> char '_'

-- | Possible characters for identifiers (not for the first character).
identLetter ∷ P Char
identLetter = letter <|> digit <|> char '_' <|> char '\''

-- | A list of allowed commands
commands ∷ Array String
commands = ["help", "?", "list", "ls", "ll", "reset", "clear", "cls", "quit", "exit"]

-- | The language definition.
insectLanguage ∷ LanguageDef
insectLanguage = LanguageDef
  { commentStart: ""
  , commentEnd: ""
  , commentLine: "#"
  , nestedComments: false
  , identStart: identStart
  , identLetter: identLetter
  , opStart: oneOf ['+', '-', '*', '·', '⋅', '×', '/', '÷', '%', '^', '!', '→', '➞', '=']
  , opLetter: oneOf []
  , reservedNames: commands <> ["¹", "²", "³", "⁴", "⁵", "⁻¹", "⁻²", "⁻³", "⁻⁴", "⁻⁵", "to", "per"]
  , reservedOpNames: ["->", "+", "-", "*", "·", "⋅", "×", "/", "÷", "%", "^", "!",
                      "**", "=", ","]
  , caseSensitive: true
}

-- | The actual token parser.
token ∷ TokenParser
token = makeTokenParser insectLanguage

-- | Parse something, inside of parens.
parens ∷ ∀ a. P a → P a
parens = token.parens

-- | Parse one of the reserved operators.
reservedOp ∷ String → P Unit
reservedOp = token.reservedOp

-- | Parse a reserverd keyword.
reserved ∷ String → P Unit
reserved = token.reserved

-- | Parse zero or more whitespace characters.
whiteSpace ∷ P Unit
whiteSpace = token.whiteSpace

-- | Parse a number.
number ∷ P Decimal
number = do
  intPart ← digits

  mFracPart ← optionMaybe (append <$> string "." <*> digits)
  let fracPart = fromMaybe "" mFracPart

  mExpPart ← optionMaybe $ try do
    _ ← string "e"
    notFollowedBy identStart
    sad ← signAndDigits
    pure ("e" <> sad)
  let expPart = fromMaybe "" mExpPart

  whiteSpace

  let floatStr = intPart <> fracPart <> expPart

  case fromString floatStr of
    Just num →
      if isFinite num
      then pure num
      else fail "This number is too large"
    Nothing → fail $ "Parsing of number failed for input '" <> floatStr <> "'"

  where
    digits ∷ P String
    digits = do
      ds ← some $ oneOf ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'] <?> "a digit"
      pure $ fromCharArray (fromFoldable ds)

    signAndDigits ∷ P String
    signAndDigits = do
      sign ← option '+' (oneOf ['+', '-'])
      intPart ← digits
      pure $ singleton sign <> intPart

-- | A helper type for entries in the dictionary.
data DictEntry a = DictEntry a (Array String)

infix 4 DictEntry as ==>

-- | A dictionary of units and their abbreviations.
data Dictionary a = Dictionary (Array (DictEntry a))

-- | Build a parser from a Dictionary
buildDictParser ∷ ∀ a. Dictionary a → P a
buildDictParser (Dictionary dict) = F.oneOf $ entryParser <$> dict
  where
    entryParser (x ==> abbrevs) = F.oneOf $ abbrevParser x <$> abbrevs
    abbrevParser x abbrev = string abbrev *> pure x

prefixDict ∷ Dictionary (DerivedUnit → DerivedUnit)
prefixDict = Dictionary
  [ Q.kibi ==> ["kibi", "Ki"]
  , Q.mebi ==> ["mebi", "Mi"]
  , Q.gibi ==> ["gibi", "Gi"]
  , Q.tebi ==> ["tebi", "Ti"]
  , Q.pebi ==> ["pebi", "Pi"]
  , Q.exbi ==> ["exbi", "Ei"]
  , Q.zebi ==> ["zebi", "Zi"]
  , Q.yobi ==> ["yobi", "Yi"]
  , Q.atto ==> ["atto", "a"]
  , Q.femto ==> ["femto", "f"]
  -- peta and mega have to be up here (before pico and milli) in order for the
  -- prefixes ('p' and 'm') not to be parsed as 'pico' or 'milli'.
  , Q.peta ==> ["peta"]
  , Q.mega ==> ["mega"]
  , Q.pico ==> ["pico", "p"]
  , Q.nano ==> ["nano", "n"]
  , Q.micro ==> [ "micro"
                , "u" -- u for micro
                , "µ" -- Micro sign U+00B5
                , "μ" -- Greek small letter mu U+039C
                ]
  , Q.milli ==> ["milli", "m"]
  , Q.centi ==> ["centi", "c"]
  , Q.deci ==> ["deci", "d"]
  , Q.hecto ==> ["hecto", "h"]
  , Q.kilo ==> ["kilo", "k"]
  , Q.mega ==> ["M"]
  , Q.giga ==> ["giga", "G"]
  , Q.tera ==> ["tera", "T"]
  , Q.peta ==> ["P"]
  , Q.exa ==> ["exa", "E"]
  ]

-- | Parse a SI or IEC prefix like `µ`, `G`, `pico` or `Ki`.
prefix ∷ P (DerivedUnit → DerivedUnit)
prefix = buildDictParser prefixDict <|> pure id

-- | Normal (SI-conform, non-imperial) units
normalUnitDict ∷ Dictionary DerivedUnit
normalUnitDict = Dictionary
  [ Q.radian ==> ["radians", "radian", "rad"]
  , Q.degree ==> ["degrees", "degree", "deg", "°"]
  , Q.hertz ==> ["hertz", "Hz"]
  , Q.rpm ==> ["RPM", "rpm"]
  , Q.newton ==> ["newton", "N"]
  , Q.joule ==> ["joules", "joule", "J"]
  , Q.pascal ==> ["pascal", "Pa"]
  , Q.volt ==> ["volts", "volt", "V"]
  , Q.farad ==> ["farad", "F"]
  , Q.ohm ==> ["ohms", "ohm", "Ω"]
  , Q.sievert ==> ["sievert", "Sv"]
  , Q.weber ==> ["weber", "Wb"]
  , Q.tesla ==> ["tesla", "T"]
  , Q.henry ==> ["henry", "H"]
  , Q.coulomb ==> ["coulomb", "C"]
  , Q.siemens ==> ["siemens", "S"]
  , Q.lumen ==> ["lumen", "lm"]
  , Q.lux ==> ["lux", "lx"]
  , Q.becquerel ==> ["becquerel", "Bq"]
  , Q.gray ==> ["gray", "Gy"]
  , Q.katal ==> ["katal", "kat"]
  , Q.hectare ==> ["hectare", "ha"]
  , Q.tonne ==> ["tonnes", "tonne", "tons", "ton"]
  , Q.electronvolt ==> ["electronvolt", "eV"]
  , Q.calorie ==> ["calories", "calorie", "cal"]
  , Q.bel ==> ["bel"]
  , Q.astronomicalUnit ==> ["AU"]
  , Q.parsec ==> ["parsecs", "parsec", "pc"]
  , Q.lightyear ==> ["lightyears", "lightyear", "ly"]
  , Q.barn ==> ["barn"]
  , Q.bar ==> ["bar"]
  , Q.angstrom ==> ["angstrom", "Å"]
  , Q.gauss ==> ["gauss"]
  , Q.ampere ==> ["amperes", "ampere", "A"]
  , Q.mole ==> ["mole", "mol"]
  , Q.kelvin ==> ["kelvin", "K"]
  , Q.candela ==> ["candela", "cd"]
  , Q.watt <> Q.hour ==> ["Wh"]
  , Q.watt ==> ["watts", "watt", "W"]
  , Q.byte ==> ["Bytes", "bytes", "Byte", "byte", "B", "Octets", "octets", "Octet", "octet"]
  , Q.bit ==> ["bits", "bit"]
  , Q.bit ./ Q.second ==> ["bps"]
  , Q.second ==> ["seconds", "second", "sec", "s"]
  , Q.minute ==> ["minutes", "minute", "min"]
  , Q.hour ==> ["hours", "hour", "h"]
  , Q.day ==> ["days", "day"]
  , Q.week ==> ["weeks", "week"]
  , Q.fortnight ==> ["fortnights", "fortnight"]
  , Q.month ==> ["months", "month"]
  , Q.year ==> ["years", "year"]
  , Q.gram ==> ["grammes", "gramme", "grams", "gram", "g"]
  , Q.meter ==> ["metres", "metre", "meters", "meter", "m"]
  , Q.liter ==> ["liters", "liter", "litres", "litre", "L", "l"]
  , Q.atm ==> ["atm"]
  ]

-- | Parse a normal (SI-conform, non-imperical) unit, like `N` or `watt`.
normalUnit ∷ P DerivedUnit
normalUnit = buildDictParser normalUnitDict <?> "normal unit"

-- | Imperial units
imperialUnitDict ∷ Dictionary DerivedUnit
imperialUnitDict = Dictionary
  [ Q.mile ==> ["miles", "mile"]
  , Q.mile ./ Q.hour ==> ["mph"]
  , Q.inch ==> ["inches", "inch", "in"]
  , Q.yard ==> ["yards", "yard", "yd"]
  , Q.foot ==> ["feet", "foot", "ft"]
  , Q.ounce ==> ["ounces", "ounce", "oz"]
  , Q.pound ==> ["pounds", "pound", "lb"]
  , Q.gallon ==> ["gallons", "gallon", "gal"]
  , Q.pint ==> ["pints", "pint"]
  , Q.cup ==> ["cups", "cup"]
  , Q.tablespoon ==> ["tablespoons", "tablespoon", "tbsp"]
  , Q.teaspoon ==> ["teaspoons", "teaspoon", "tsp"]
  , Q.fluidounce ==> ["fluidounces", "fluidounce", "floz"]
  , Q.furlong ==> ["furlong"]
  , Q.btu ==> ["BTU"]
  , Q.psi ==> ["psi"]
  , Q.mmHg ==> ["mmHg"]
  , Q.hogshead ==> ["hogsheads", "hogshead"]
  , Q.rod ==> ["rods", "rod"]
  ]

-- | Parse an imperial unit like `ft` of `mile`.
imperialUnit ∷ P DerivedUnit
imperialUnit = buildDictParser imperialUnitDict <?> "imperial unit"

-- | Parse a 'normal' unit with SI prefix, like `km` or `Gb`.
unitWithSIPrefix ∷ P DerivedUnit
unitWithSIPrefix = do
  p ← prefix
  u ← normalUnit
  pure $ p u

specialCases ∷ P DerivedUnit
specialCases =
  -- The abbreviation 'd' for 'day' needs to be treated separately. Otherwise,
  -- 'cd' will be parsed as 'centi day' instead of 'candela'.
      string "d" *> pure Q.day
  -- Similarly, the abbreviation 't' for 'tonne' needs special treatment.
  -- Otherwise, 'ft' will be parsed as 'femto tonne' instead of 'feet'.
  <|> string "t" *> pure Q.tonne

-- | Parse a derived unit, like `km`, `ft`, or `s`.
derivedUnit ∷ P DerivedUnit
derivedUnit =
  (
        try (augment unitWithSIPrefix)
    <|> augment imperialUnit
    <|> augment normalUnit
    <|> augment specialCases
  ) <* whiteSpace
  where
    augment p = p <* notFollowedBy identLetter

-- | Parse the name of a variable, like `my_variable'`.
variable ∷ P Expression
variable = Variable <$> token.identifier

-- | A version of `sepBy1` that returns a `NonEmpty List`.
sepBy1 ∷ ∀ m s a sep. Monad m ⇒ ParserT s m a → ParserT s m sep → ParserT s m (NonEmpty List a)
sepBy1 p sep = do
  a ← p
  as ← many $ sep *> p
  pure (a :| as)

-- | Fold a non-empty structure, collecting results using a binary operation.
foldr1 ∷ ∀ a. (a → a → a) → NonEmpty List a → a
foldr1 f (a :| xs) =
  case init xs, last xs of
    Just bs, Just b → f a (foldr f b bs)
    _, _ → a

-- | Parse a function name and fail if it's not in the environment
function ∷ Environment → P Identifier
function env = do
  name ← token.identifier
  case lookup name env.functions of
    Just (StoredFunction _ fn) → pure name
    Nothing → fail ("Unknown function '" <> name <> "'")

-- | Parse a full mathematical expression.
expression ∷ Environment → P Expression
expression env =
  fix \p →
    let
      atomic ∷ P Expression
      atomic = whiteSpace *> (
              parens p
          <|> (Scalar <$> number)
          <|> try (Unit <$> derivedUnit)
          <|> try (Apply <$> function env <*> parens (sepBy1 p commaOp))
          <|> variable
          )

      suffixFac ∷ P Expression
      suffixFac = do
        a ← atomic
        mf ← optionMaybe (facOp *> pure Factorial)
        case mf of
          Just f → pure $ f a
          Nothing → pure a

      suffixPow ∷ P Expression
      suffixPow = do
        x ← suffixFac
        mFn ← optionMaybe (     reservedOp "¹" *>  pure (powPos 1.0)
                            <|> reservedOp "²" *>  pure (powPos 2.0)
                            <|> reservedOp "³" *>  pure (powPos 3.0)
                            <|> reservedOp "⁴" *>  pure (powPos 4.0)
                            <|> reservedOp "⁵" *>  pure (powPos 5.0)
                            <|> reservedOp "⁻¹" *> pure (powNeg 1.0)
                            <|> reservedOp "⁻²" *> pure (powNeg 2.0)
                            <|> reservedOp "⁻³" *> pure (powNeg 3.0)
                            <|> reservedOp "⁻⁴" *> pure (powNeg 4.0)
                            <|> reservedOp "⁻⁵" *> pure (powNeg 5.0)
                          )
        case mFn of
          Just fn → pure $ fn x
          Nothing → pure x

      sepByPow ∷ P Expression
      sepByPow = foldr1 (BinOp Pow) <$> suffixPow `sepBy1` powOp

      sepByMulImplicit ∷ P Expression
      sepByMulImplicit = foldl1 (BinOp Mul) <$> sepByPow `sepBy1` pure unit

      sepByMod ∷ P Expression
      sepByMod = foldl1 (BinOp Mod) <$> sepByMulImplicit `sepBy1` modOp

      sepByDiv ∷ P Expression
      sepByDiv = foldl1 (BinOp Div) <$> sepByMod `sepBy1` divOp

      sepByMul ∷ P Expression
      sepByMul = foldl1 (BinOp Mul) <$> sepByDiv `sepBy1` mulOp

      prefixed ∷ P Expression
      prefixed = do
        prefixFn ← ((subOp *> pure Negate) <|> (addOp *> pure id) <|> pure id)
        prefixFn <$> sepByMul

      sepBySub ∷ P Expression
      sepBySub = foldl1 (BinOp Sub) <$> prefixed `sepBy1` subOp

      sepByAdd ∷ P Expression
      sepByAdd = foldl1 (BinOp Add) <$> sepBySub `sepBy1` addOp

      sepByConv ∷ P Expression
      sepByConv = foldl1 (BinOp ConvertTo) <$> sepByAdd `sepBy1` arrOp

    in sepByConv

  where

    commaOp = reservedOp ","
    facOp = reservedOp "!"
    powOp = reservedOp "^" <|> reservedOp "**"
    modOp = reservedOp "%"
    divOp = reservedOp "/" <|> reservedOp "÷" <|> reserved "per"
    mulOp = reservedOp "*" <|> reservedOp "·" <|> reservedOp "⋅"
                           <|> reservedOp "×"
    subOp = reservedOp "-"
    addOp = reservedOp "+"
    arrOp = reservedOp "->" <|> reservedOp "→" <|> reservedOp "➞" <|> reserved "to"

    powPos s q | s == 1.0  = q
               | otherwise = BinOp Pow q (Scalar $ fromNumber s)
    powNeg s q = BinOp Pow q (Negate $ Scalar $ fromNumber s)

-- | Parse a mathematical expression (or conversion) like `3m+2in -> cm`.
fullExpression ∷ Environment → P Expression
fullExpression env = do
  whiteSpace
  expr ← expression env
  eof <?> "end of input"

  pure $ expr

-- | Parse an Insect command.
command ∷ P Command
command =
  (
        (reserved "help" <|> reserved "?") *> pure Help
    <|> (reserved "list" <|> reserved "ls" <|> reserved "ll") *> pure List
    <|> (reserved "reset") *> pure Reset
    <|> (reserved "clear" <|> reserved "cls") *> pure Clear
    <|> (reserved "quit" <|> reserved "exit") *> pure Quit
  ) <* eof

-- | Parse a variable- or function assignment.
assignment ∷ Environment → P Statement
assignment env = do
  { name, args, expr } ←
    try do
      whiteSpace
      name ← token.identifier
      args ← optionMaybe (parens (sepBy1 token.identifier (reservedOp ",")))
      reservedOp "="
      expr ← expression env
      eof

      pure { name: name, args: args, expr: expr }

  -- Fail if the name can be parsed as a physical unit
  when (isRight $ runParser name (derivedUnit <* eof)) $
    fail ("'" <> name <> "' is reserved for a physical unit")

  case args of
    Nothing → pure (VariableAssignment name expr)
    Just xs → pure (FunctionAssignment name xs expr)

-- | Parse a statement in the Insect language.
statement ∷ Environment → P Statement
statement env =
      (Command <$> command)
  <|> assignment env
  <|> (Expression <$> fullExpression env)

-- | Run the Insect-parser on a `String` input.
parseInsect ∷ Environment → String → Either ParseError Statement
parseInsect env inp = runParser inp (statement env)


Added an example

Added an example

module Main where

import Network.XMLHttpRequest

main = do
    xr <- startXHR
    xr' <- assignOnload xr (getResponseText)
    xr'' <- open xr' (show GET) "#"
    xrP <- sendEmpty xr''
    Debug.Trace.trace "Worky?"

error: pathspec 'examples/BasicGet.purs' did not match any file(s) known to git


Add project root command (#19)

Add project root command (#19)

module PscIde.Project where

import Prelude
import Node.Path as NP
import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe(..))
import Node.FS (FS) as FS
import Node.FS.Sync (exists) as FS

-- | Get PureScript project root given a .purs file (identified by presence of bower.json)
getRoot :: forall eff'. NP.FilePath -> Eff (fs :: FS.FS | eff') (Maybe NP.FilePath)
getRoot path =
  let parent = getParent path
      bower = NP.concat [path, "bower.json"] in
  if path == "" || path == parent then
    pure Nothing
  else do
    hasBower <- FS.exists bower
    if hasBower then pure $ Just path else getRoot parent

  where
    getParent :: NP.FilePath -> NP.FilePath
    getParent p = NP.concat [p, ".."]

error: pathspec 'src/PscIde/Project.purs' did not match any file(s) known to git


Added Application.Types module containing all type declarations

module Application.Types where

import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Prelude (class Eq, class Show)

data ApplicationState = ApplicationState Number Number

derive instance eqApplicationState :: Eq ApplicationState
derive instance genericApplicationState :: Generic ApplicationState _

instance showApplicationState :: Show ApplicationState where
	show = genericShow

error: pathspec 'src/Application/Types.purs' did not match any file(s) known to git


Another test

Another test

module Main where

f x y z =
  let f 1 2 3 = 1
  in f x z y

main = Debug.Trace.trace $ show $ f 1 3 2

error: pathspec 'examples/passing/ShadowedTCOLet.purs' did not match any file(s) known to git


Add Overlay component as a base for modals and spinners

module Components.Overlay
  ( new
  ) where

import Lambda.Prelude

import React.Basic (JSX)
import React.Basic.DOM as R
import React.Basic.Hooks (Component, component)
import React.Portal as Portal
import React.Basic.Events (handler)
import React.Basic.DOM.Events (stopPropagation)

type Props =
  { dismiss :: Maybe (Effect Unit)
  , children :: Array JSX
  }

new :: Component Props
new = do
  portal <- Portal.new
  component "Overlay" \{ dismiss, children } ->
    pure $ portal
      { children:
        [ R.div
          { className: "overlay"
          , children:
            [ R.div
              { className: "overlay-item"
              , children
              }
            ]
          , onClick: handler stopPropagation $ const $ sequence_ dismiss
          }
        ]
      }

error: pathspec 'frontend/src/Components/Overlay.purs' did not match any file(s) known to git


Add Ring instance

Add Ring instance

module Data.Int
  ( Int()
  , fromNumber
  , toNumber
  ) where

newtype Int = Int Number

-- | Creates an `Int` from a `Number` value. If the value is not already an
-- | integer it is rounded down.
foreign import fromNumber
  """
  function fromNumber(n) {
    return n|0
  }
  """ :: Number -> Int

toNumber :: Int -> Number
toNumber (Int n) = n

instance showInt :: Show Int where
  show (Int n) = "fromNumber " ++ show n

instance eqInt :: Eq Int where
  (==) (Int x) (Int y) = x == y
  (/=) (Int x) (Int y) = x /= y

instance ordInt :: Ord Int where
  compare (Int x) (Int y) = compare x y

instance semiringInt :: Semiring Int where
  (+) = intAdd
  zero = Int 0
  (*) = intMul
  one = Int 1

instance moduloSemiringInt :: ModuloSemiring Int where
  (/) = intDiv
  mod = intMod

instance ringInt :: Ring Int where
  (-) = intMinus

instance bitsInt :: Bits Int where
  (.&.) (Int x) (Int y) = Int (x .&. y)
  (.|.) (Int x) (Int y) = Int (x .|. y)
  (.^.) (Int x) (Int y) = Int (x .^. y)
  shl (Int x) y = Int (x `shl` y)
  shr (Int x) y = Int (x `shr` y)
  zshr (Int x) y = Int (x `zshr` y)
  complement (Int n) = Int (complement n)

foreign import intAdd
  """
  function intAdd(x) {
    return function(y) {
      return x + y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMul
  """
  function intMul(x) {
    return function(y) {
      return x * y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intDiv
  """
  function intDiv(x) {
    return function(y) {
      return (x / y)|0;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMod
  """
  function intDiv(x) {
    return function(y) {
      return (x % y + y) % y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMinus
  """
  function intDiv(x) {
    return function(y) {
      return x - y;
    };
  }
  """ :: Int -> Int -> Int

module Data.Int
  ( Int()
  , fromNumber
  , toNumber
  ) where

newtype Int = Int Number

-- | Creates an `Int` from a `Number` value. If the value is not already an
-- | integer it is rounded down.
foreign import fromNumber
  """
  function fromNumber(n) {
    return n|0
  }
  """ :: Number -> Int

toNumber :: Int -> Number
toNumber (Int n) = n

instance showInt :: Show Int where
  show (Int n) = "fromNumber " ++ show n

instance eqInt :: Eq Int where
  (==) (Int x) (Int y) = x == y
  (/=) (Int x) (Int y) = x /= y

instance ordInt :: Ord Int where
  compare (Int x) (Int y) = compare x y

instance semiringInt :: Semiring Int where
  (+) = intAdd
  zero = Int 0
  (*) = intMul
  one = Int 1

instance moduloSemiringInt :: ModuloSemiring Int where
  (/) = intDiv
  mod = intMod

instance bitsInt :: Bits Int where
  (.&.) (Int x) (Int y) = Int (x .&. y)
  (.|.) (Int x) (Int y) = Int (x .|. y)
  (.^.) (Int x) (Int y) = Int (x .^. y)
  shl (Int x) y = Int (x `shl` y)
  shr (Int x) y = Int (x `shr` y)
  zshr (Int x) y = Int (x `zshr` y)
  complement (Int n) = Int (complement n)

foreign import intAdd
  """
  function intAdd(x) {
    return function(y) {
      return x + y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMul
  """
  function intMul(x) {
    return function(y) {
      return x * y;
    };
  }
  """ :: Int -> Int -> Int

foreign import intDiv
  """
  function intDiv(x) {
    return function(y) {
      return (x / y)|0;
    };
  }
  """ :: Int -> Int -> Int

foreign import intMod
  """
  function intDiv(x) {
    return function(y) {
      return (x % y + y) % y;
    };
  }
  """ :: Int -> Int -> Int


Add test case covering new row syntax

Add test case covering new row syntax

module Main where

type Foo = (x :: Number | (y :: Number | (z :: Number)))
type Bar = (x :: Number, y :: Number, z :: Number)
type Baz = { w :: Number | Bar }

foo :: { | Foo }
foo = { x: 0, y: 0, z: 0 }

bar :: { | Bar }
bar = { x: 0, y: 0, z: 0 }

id' :: Object Foo -> Object Bar
id' = id

foo' :: { | Foo }
foo' = id' foo

bar' :: { | Bar }
bar' = id' bar

baz :: Baz
baz = { x: 0, y: 0, z: 0, w: 0 }

main = Debug.Trace.trace "Done"

error: pathspec 'examples/passing/RowConstructors.purs' did not match any file(s) known to git


expedition, required compo

expedition, required compo

module KanColle.Expedition.New.Compo where

import Prelude
import Data.Maybe
import KanColle.Expedition.New.SType
import Data.Unfoldable
import Data.Array as A

-- Nothing: ship type not specified
-- Just <stype>: must be of ship type <stype>
type FleetCompo = Array (Maybe SType)

expedCompositions :: Array FleetCompo
expedCompositions =
    [ -- Exped 1
      atLeast 2 []
    , -- Exped 2
      atLeast 4 []
    , -- Exped 3
      atLeast 3 []
    , -- Exped 4
      sty 1 CL <> sty 2 DD
    , -- Exped 5
      atLeast 4 (sty 1 CL <> sty 2 DD)
    , -- Exped 6
      atLeast 4 []
    , -- Exped 7
      full []
    , -- Exped 8
      full []

    , -- Exped 9
      atLeast 4 (sty 1 CL <> sty 2 DD)
    , -- Exped 10
      atLeast 3 (sty 2 CL)
    , -- Exped 11
      atLeast 4 (sty 2 DD)
    , -- Exped 12
      atLeast 4 (sty 2 DD)
    , -- Exped 13
      full (sty 1 CL <> sty 4 DD)
    , -- Exped 14
      full (sty 1 CL <> sty 3 DD)
    , -- Exped 15
      full (sty 2 CVLLike <> sty 2 DD)
    , -- Exped 16
      full (sty 1 CL <> sty 2 DD)

    , -- Exped 17
      full (sty 1 CL <> sty 3 DD)
    , -- Exped 18
      full (sty 3 CVLLike <> sty 2 DD)
    , -- Exped 19
      full (sty 2 BBV <> sty 2 DD)
    , -- Exped 20
      sty 1 SSLike <> sty 1 CL
    , -- Exped 21
      sty 1 CL <> sty 4 DD
    , -- Exped 22
      full (sty 1 CA <> sty 1 CL <> sty 2 DD)
    , -- Exped 23
      full (sty 2 BBV <> sty 2 DD)
    , -- Exped 24
      full (sty 1 CL <> sty 4 DD)

    , -- Exped 25
      sty 2 CA <> sty 2 DD
    , -- Exped 26
      sty 1 CVLLike <> sty 1 CL <> sty 2 DD
    , -- Exped 27
      sty 2 SSLike
    , -- Exped 28
      sty 3 SSLike
    , -- Exped 29
      sty 3 SSLike
    , -- Exped 30
      sty 4 SSLike
    , -- Exped 31
      sty 4 SSLike
    , -- Exped 32
      sty 1 CT <> sty 2 DD

    , -- Exped 33
      sty 2 DD
    , -- Exped 34
      sty 2 DD
    , -- Exped 35
      full (sty 2 CVLLike <> sty 1 CA <> sty 1 DD)
    , -- Exped 36
      full (sty 2 AV <> sty 1 CL <> sty 1 DD)
    , -- Exped 37
      sty 1 CL <> sty 5 DD
    , -- Exped 38
      full (sty 5 DD)
    , -- Exped 39
      sty 1 AS <> sty 4 SSLike
    , -- Exped 40
      full (sty 1 CL <> sty 2 AV <> sty 2 DD)
    ]
  where
    full = atLeast 6
    -- fill wildcards to a composition
    -- to meet the ship number requirement
    atLeast :: Int -> FleetCompo -> FleetCompo
    atLeast n compo = if A.length compo < n
        then compo <> replicate (n - A.length compo) Nothing
        else compo
    sty :: Int -> SType -> FleetCompo
    sty n st = replicate n (Just st)

error: pathspec 'src/KanColle/Expedition/New/Compo.purs' did not match any file(s) known to git


Now you need to specify explicitly whether a request has content.


Add a silly example

Add a silly example

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/freebroccolo/purescript-d3.git/'


First pass at Atom module

First pass at Atom module

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/freebroccolo/purescript-atom-api.git/'


MonadState example

MonadState example

module Main where

import Prelude
import Data.Tuple

class MonadState s m where
  get :: m s
  put :: s -> m {}

data State s a = State (s -> Tuple s a)

runState s (State f) = f s

instance Prelude.Monad (State s) where
  return a = State $ \s -> Tuple s a
  (>>=) f g = State $ \s -> let (Tuple s1 a) = runState s f in
                            runState s1 (g a)

instance MonadState s (State s) where
  get = State (\s -> Tuple s s)
  put s = State (\_ -> Tuple s {})

modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {}
modify f = do
  s <- get
  put (f s)

test :: Tuple String String
test = runState "" $ do
  modify $ (++) "World!"
  modify $ (++) "Hello, "
  get

main = Debug.Trace.print test

error: pathspec 'examples/passing/MonadState.purs' did not match any file(s) known to git


Test for referencing unexported values within a module

In advance of fix for #245

module M1 (bar) where

  foo :: Number
  foo = 0

  bar :: Number
  bar = foo

module Main where

  import M1

  testBar = bar

  main = Debug.Trace.trace "Done"

error: pathspec 'examples/passing/ExportExplicit2.purs' did not match any file(s) known to git


Add support for dangerouslySetInnerHTML

Add support for dangerouslySetInnerHTML

-- | This module defines unsafe helper functions for creating HTML attributes.

module Thermite.Html.Attributes.Unsafe where

import Thermite.Types
import Thermite.Internal

innerHTML :: String -> Attr
innerHTML s = unsafeAttribute "dangerouslySetInnerHTML" { "__html": s }

error: pathspec 'src/Thermite/Html/Attributes/Unsafe.purs' did not match any file(s) known to git


Small refactorings.

Small refactorings.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/raduom/minos.git/'


Start/Stop baby station now works on chrome

module Gonimo.UI.Socket where

import Prelude
import Data.Array as Arr
import Data.Map as Map
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import WebRTC.MediaStream.Track as Track
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Reader (ask, runReader)
import Control.Monad.Reader.Class (class MonadReader, ask)
import Control.Monad.State.Class (gets, modify, put, get, class MonadState)
import Data.Array (fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (maybe, fromMaybe, Maybe(Nothing, Just))
import Data.Monoid (mempty)
import Data.Traversable (traverse_)
import Data.Tuple (uncurry, snd, Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (wrapAction, noEffects, runGonimo, Component, liftChild, toParent, ComponentType, makeChildData, ToChild, onlyModify, Update, class MonadComponent)
import Gonimo.Server.DbEntities (Family(Family), Device(Device))
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Lenses (currentFamily, onlineStatus, authData)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (BabyStation, toCSecret, toTheirId, makeChannelId, ChannelId(ChannelId), channel, Props, State, Action(..))
import Gonimo.WebAPI (deleteOnlineStatusByFamilyIdByDeviceId)
import Gonimo.WebAPI.Lenses (_AuthData, deviceId)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByToDevice, receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Servant.Subscriber (Subscriptions)
import WebRTC.MediaStream (MediaStreamConstraints(MediaStreamConstraints), getUserMedia, MediaStream, getTracks)
import WebRTC.RTC (RTCPeerConnection)
import Gonimo.Client.Effects as Console

-- We only use props for initialization
init :: AuthData-> State
init authData' = { authData : authData'
                 , currentFamily : Nothing
                 , channels : Map.empty
                 , onlineStatus : Nothing
                 }

update :: forall ps. Update (Props ps) State Action
update action = case action of
  AcceptConnection channelId'                    -> handleAcceptConnection channelId'
  AddChannel channelId' cState                   -> channel channelId' .= Just cState
                                                    *> pure []
  ChannelA channelId' (ChannelC.ReportError err) -> pure [pure $ ReportError err]
  ChannelA channelId' action'                    -> updateChannel channelId' action'
  CloseChannel channelId'                        -> pure [ pure $ ChannelA channelId' ChannelC.CloseConnection
                                                         , pure $ RemoveChannel channelId'
                                                         ]
  CloseBabyChannel channelId'                    -> do
    isBabyStation' <- gets (_^?channel channelId' <<< _Just <<< to _.isBabyStation)
    case isBabyStation' of
         Just true                               -> pure $ wrapAction (CloseBabyChannel channelId')
         _                                       -> pure []
  RemoveChannel channelId'                       -> channel channelId' .= Nothing
                                                    *> pure []
  (SwitchFamily familyId')                       -> handleFamilySwitch familyId'
  (ServerFamilyGoOffline familyId)               -> handleServerFamilyGoOffline familyId
  (SetAuthData auth)                             -> handleSetAuthData auth
  (StartBabyStation baby constraints)            -> handleStartBabyStation baby constraints
  (InitBabyStation baby stream)                  -> onlineStatus .= Just { babyName : baby, mediaStream : stream }
                                                    *> pure []
  (ConnectToBaby _ )                             -> noEffects
  StopBabyStation                                -> handleStopBabyStation
  (ReportError _)                                -> noEffects
  Nop                                            -> noEffects

toChannel :: forall ps. ChannelId -> ToChild (Props ps) State (ChannelC.Props {}) ChannelC.State
toChannel channelId' = do
  state <- get
  pProps <- ask
  let
    props :: ChannelC.Props {}
    props = mkChannelProps pProps state channelId'
  pure $ makeChildData (channel channelId' <<< _Just) props

handleStartBabyStation :: forall ps.
                          String
                       -> MediaStreamConstraints
                       -> ComponentType (Props ps) State Action
handleStartBabyStation baby constraints =
  runGonimo $
    InitBabyStation baby <$> liftAff (getUserMedia constraints)

handleAcceptConnection :: forall ps. ChannelId -> ComponentType (Props ps) State  Action
handleAcceptConnection channelId' = do
  state <- get
  pure [ AddChannel channelId' <$> ChannelC.init state.onlineStatus ]

handleFamilySwitch :: forall ps. Key Family -> ComponentType (Props ps) State Action
handleFamilySwitch familyId' = do
    state <- get :: Component (Props ps) State State
    let oldFamily = state.currentFamily
    modify $ _ { currentFamily = Just familyId' }
    let action = fromFoldable
                 $ pure <<< ServerFamilyGoOffline
                 <$> oldFamily
    pure $ doCleanup state CloseChannel action

handleSetAuthData :: forall ps. AuthData -> ComponentType (Props ps) State Action
handleSetAuthData auth = do
  state <- get
  authData .= auth
  pure $ doCleanup state CloseChannel []

handleStopBabyStation :: forall ps. ComponentType (Props ps) State Action
handleStopBabyStation = do
  state <- get :: Component (Props ps) State State
  props <- ask :: Component (Props ps) State (Props ps)
  onlineStatus .= (Nothing :: Maybe BabyStation)
  let action = case state.onlineStatus of
        Nothing -> []
        Just station -> [ toIO props.settings <<< liftEff $ do
                             tracks <- getTracks station.mediaStream
                             traverse_ Track.stop tracks
                             pure Nop
                        ]
  pure $ doCleanup state CloseBabyChannel action

handleServerFamilyGoOffline :: forall ps. Key Family -> ComponentType (Props ps) State Action
handleServerFamilyGoOffline familyId = do
    state <- get
    let deviceId = (runAuthData state.authData).deviceId
    runGonimo $ do
      deleteOnlineStatusByFamilyIdByDeviceId familyId deviceId
      pure Nop

updateChannel :: forall ps. ChannelId -> ChannelC.Action -> ComponentType (Props ps) State Action
updateChannel channelId' = toParent [] (ChannelA channelId')
                           <<< liftChild (toChannel channelId')
                           <<< ChannelC.update

doCleanup :: State -> (ChannelId -> Action) -> Array (IO Action) -> Array (IO Action)
doCleanup state cleanup action =
    if Map.isEmpty state.channels
    then action
    else Arr.fromFoldable (pure <<< cleanup <$> Map.keys state.channels)
         <> action

getSubscriptions :: forall ps. Props ps -> State -> Subscriptions Action
getSubscriptions props state =
  let
    authData' = state ^. authData <<< to runAuthData
    familyId' = state ^. currentFamily
    receiveAChannel deviceId' familyId'' =
      receiveSocketByFamilyIdByToDevice
        (maybe Nop (AcceptConnection <<< uncurry makeChannelId ))
        familyId''
        deviceId'

    getChannelSubscriptions :: forall m. (MonadReader Settings m)
                                  => ChannelId -> m (Subscriptions Action)
    getChannelSubscriptions channelId' =
      let
        cProps = mkChannelProps props state channelId'
      in
      map (ChannelA channelId') <$> ChannelC.getSubscriptions cProps

    getChannelsSubscriptions :: forall m. (MonadReader Settings m)
                                => Map ChannelId ChannelC.State
                                -> Array (m (Subscriptions Action))
    getChannelsSubscriptions = Arr.fromFoldable <<< map getChannelSubscriptions <<< Map.keys

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader props.settings)
                $ getChannelsSubscriptions state.channels
                <> fromFoldable (receiveAChannel authData'.deviceId <$> familyId')
  in
     foldl append mempty subArray

mkChannelProps :: forall ps. Props ps -> State -> ChannelId -> ChannelC.Props {}
mkChannelProps props state channelId = { ourId : state ^. authData <<< to runAuthData <<< deviceId
                                       , theirId : toTheirId channelId
                                       , cSecret : toCSecret channelId
                                       , familyId : ChannelC.unsafeMakeFamilyId state.currentFamily
                                       , settings : props.settings
                                       }

module Gonimo.UI.Socket where

import Prelude
import Data.Array as Arr
import Data.Map as Map
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.IO (IO)
import Control.Monad.Reader (ask, runReader)
import Control.Monad.Reader.Class (class MonadReader, ask)
import Control.Monad.State.Class (gets, modify, put, get, class MonadState)
import Data.Array (fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (maybe, fromMaybe, Maybe(Nothing, Just))
import Data.Monoid (mempty)
import Data.Tuple (uncurry, snd, Tuple(Tuple))
import Gonimo.Client.Types (Settings)
import Gonimo.Pux (wrapAction, noEffects, runGonimo, Component, liftChild, toParent, ComponentType, makeChildData, ToChild, onlyModify, Update, class MonadComponent)
import Gonimo.Server.DbEntities (Family(Family), Device(Device))
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Lenses (currentFamily, onlineStatus, authData)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (BabyStation, toCSecret, toTheirId, makeChannelId, ChannelId(ChannelId), channel, Props, State, Action(..))
import Gonimo.WebAPI (deleteOnlineStatusByFamilyIdByDeviceId)
import Gonimo.WebAPI.Lenses (_AuthData, deviceId)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByToDevice, receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Servant.Subscriber (Subscriptions)
import WebRTC.MediaStream (MediaStreamConstraints(MediaStreamConstraints), getUserMedia, MediaStream)
import WebRTC.RTC (RTCPeerConnection)

-- We only use props for initialization
init :: AuthData-> State
init authData' = { authData : authData'
                 , currentFamily : Nothing
                 , channels : Map.empty
                 , onlineStatus : Nothing
                 }

update :: forall ps. Update (Props ps) State Action
update action = case action of
  AcceptConnection channelId'                    -> handleAcceptConnection channelId'
  AddChannel channelId' cState                   -> channel channelId' .= Just cState
                                                    *> pure []
  ChannelA channelId' (ChannelC.ReportError err) -> pure [pure $ ReportError err]
  ChannelA channelId' action'                    -> updateChannel channelId' action'
  CloseChannel channelId'                        -> pure [ pure $ ChannelA channelId' ChannelC.CloseConnection
                                                         , pure $ RemoveChannel channelId'
                                                         ]
  CloseBabyChannel channelId'                    -> do
    isBabyStation' <- gets (_^?channel channelId' <<< _Just <<< to _.isBabyStation)
    case isBabyStation' of
         Just true                               -> pure $ wrapAction (CloseBabyChannel channelId')
         _                                       -> pure []
  RemoveChannel channelId'                       -> channel channelId' .= Nothing
                                                    *> pure []
  (SwitchFamily familyId')                       -> handleFamilySwitch familyId'
  (ServerFamilyGoOffline familyId)               -> handleServerFamilyGoOffline familyId
  (SetAuthData auth)                             -> handleSetAuthData auth
  (StartBabyStation baby constraints)            -> noEffects
  (InitBabyStation baby stream)                  -> onlineStatus .= Just { babyName : baby, mediaStream : stream }
                                                    *> pure []
  (ConnectToBaby _ )                             -> noEffects
  StopBabyStation                                -> handleStopBabyStation
  (ReportError _)                                -> noEffects
  Nop                                            -> noEffects

toChannel :: forall ps. ChannelId -> ToChild (Props ps) State (ChannelC.Props {}) ChannelC.State
toChannel channelId' = do
  state <- get
  pProps <- ask
  let
    props :: ChannelC.Props {}
    props = mkChannelProps pProps state channelId'
  pure $ makeChildData (channel channelId' <<< _Just) props

handleStartBabyStation :: forall ps.
                          String
                       -> MediaStreamConstraints
                       -> ComponentType (Props ps) State Action
handleStartBabyStation baby constraints =
  runGonimo $
    InitBabyStation baby <$> liftAff (getUserMedia constraints)

handleAcceptConnection :: forall ps. ChannelId -> ComponentType (Props ps) State  Action
handleAcceptConnection channelId' = do
  state <- get
  pure [ AddChannel channelId' <$> ChannelC.init state.onlineStatus ]

handleFamilySwitch :: forall ps. Key Family -> ComponentType (Props ps) State Action
handleFamilySwitch familyId' = do
    state <- get :: Component (Props ps) State State
    let oldFamily = state.currentFamily
    modify $ _ { currentFamily = Just familyId' }
    let action = fromFoldable
                 $ pure <<< ServerFamilyGoOffline
                 <$> oldFamily
    pure $ doCleanup state CloseChannel action

handleSetAuthData :: forall ps. AuthData -> ComponentType (Props ps) State Action
handleSetAuthData auth = do
  state <- get
  authData .= auth
  pure $ doCleanup state CloseChannel []

handleStopBabyStation :: forall ps. ComponentType (Props ps) State Action
handleStopBabyStation = do
  state <- get :: Component (Props ps) State State
  onlineStatus .= (Nothing :: Maybe BabyStation)
  pure $ doCleanup state CloseBabyChannel []

handleServerFamilyGoOffline :: forall ps. Key Family -> ComponentType (Props ps) State Action
handleServerFamilyGoOffline familyId = do
    state <- get
    let deviceId = (runAuthData state.authData).deviceId
    runGonimo $ do
      deleteOnlineStatusByFamilyIdByDeviceId familyId deviceId
      pure Nop

updateChannel :: forall ps. ChannelId -> ChannelC.Action -> ComponentType (Props ps) State Action
updateChannel channelId' = toParent [] (ChannelA channelId')
                           <<< liftChild (toChannel channelId')
                           <<< ChannelC.update

doCleanup :: State -> (ChannelId -> Action) -> Array (IO Action) -> Array (IO Action)
doCleanup state cleanup action =
    if Map.isEmpty state.channels
    then action
    else Arr.fromFoldable (pure <<< cleanup <$> Map.keys state.channels)
         <> action

getSubscriptions :: forall ps. Props ps -> State -> Subscriptions Action
getSubscriptions props state =
  let
    authData' = state ^. authData <<< to runAuthData
    familyId' = state ^. currentFamily
    receiveAChannel deviceId' familyId'' =
      receiveSocketByFamilyIdByToDevice
        (maybe Nop (AcceptConnection <<< uncurry makeChannelId ))
        familyId''
        deviceId'

    getChannelSubscriptions :: forall m. (MonadReader Settings m)
                                  => ChannelId -> m (Subscriptions Action)
    getChannelSubscriptions channelId' =
      let
        cProps = mkChannelProps props state channelId'
      in
      map (ChannelA channelId') <$> ChannelC.getSubscriptions cProps

    getChannelsSubscriptions :: forall m. (MonadReader Settings m)
                                => Map ChannelId ChannelC.State
                                -> Array (m (Subscriptions Action))
    getChannelsSubscriptions = Arr.fromFoldable <<< map getChannelSubscriptions <<< Map.keys

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader props.settings)
                $ getChannelsSubscriptions state.channels
                <> fromFoldable (receiveAChannel authData'.deviceId <$> familyId')
  in
     foldl append mempty subArray

mkChannelProps :: forall ps. Props ps -> State -> ChannelId -> ChannelC.Props {}
mkChannelProps props state channelId = { ourId : state ^. authData <<< to runAuthData <<< deviceId
                                       , theirId : toTheirId channelId
                                       , cSecret : toCSecret channelId
                                       , familyId : ChannelC.unsafeMakeFamilyId state.currentFamily
                                       , settings : props.settings
                                       }