fixes #21: use setImmediate in _setTimeout when millis is zero

module Control.Monad.Aff
  ( Aff()
  , Canceler(..)
  , PureAff(..)
  , apathize
  , attempt
  , cancel
  , cancelWith
  , finally
  , 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) {
      var set = setTimeout, clear = clearTimeout;
      if (millis <= 0 && typeof setImmediate === "function") {
        set = setImmediate;
        clear = clearImmediate;
      }
      return function(success, error) {
        var canceler;

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

        return function(e) {
          return function(s, f) {
            if (canceler !== undefined) {
              return canceler(e)(s, f);
            } else {
              clear(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
  , finally
  , 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)


Initial foreign function bindings

Initial foreign function bindings

module Graphics.Three where

import Control.Monad.Eff
import Data.Function

foreign import data Three :: !
foreign import data Scene :: *
foreign import data Renderer :: *
foreign import data Camera :: *

foreign import createScene """
    function () {
        return new THREE.Scene();
    }
    """ :: forall eff. Eff (three :: Three) Scene

foreign import createWebGLRenderer """
    function () {
        return new THREE.WebGLRenderer();
    }
    """ :: forall eff. Eff (three :: Three) Renderer

foreign import createCamera """
    function (left, right, top, bottom, near, far) {
        new THREE.OrthographicCamera(left, right, top, bottom, near, far);
    }
    """ :: forall eff. Fn6 Number Number Number
                           Number Number Number
                           (Eff (three :: Three) Camera)

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


#594 Attachments won't necessarily be there

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/equella/Equella.git/'


Add `Base.purs`

Add `Base.purs`

module Docopt.Parsers.Base where

import Prelude
import Data.Monoid (mempty)
import Control.Apply ((*>), (<*))
import Data.Traversable (for, traverse)
import Debug.Trace (traceShow)
import Control.Monad
import Control.Alt ((<|>))
import Control.Monad.Eff.Console (log)
import Text.Parsing.Parser (Parser(), ParserT(..), PState(..))
import Text.Parsing.Parser.Pos (Position(..))
import Data.List (List(), (:))
import Text.Parsing.Parser.String (char, string, satisfy, eof, skipSpaces, whiteSpace)
import Text.Parsing.Parser.Combinators (try, sepBy)
import Data.Char (toString, toUpper)
import Data.String (charAt, fromChar, fromCharArray)
import Data.Maybe
import Data.Either
import qualified Data.List as List
import qualified Data.Array as Array
import Data.List (List(..), concat, toList, many)
import Docopt.Parsers.Base
import qualified Data.String.Regex as Regex

-- Trace `x` and return noop parser
debug :: forall a b. (Show a) => a -> Parser b Unit
debug x = traceShow x \_ -> return unit

-- Match a single space character
space :: Parser String Unit
space = char ' ' *> return unit

-- | Match a char against a regex
matches :: String -> Parser String Char
matches s = satisfy \c ->
            Regex.test (Regex.regex s Regex.noFlags) (toString c)

-- | Parse the end-of-line
eol :: Parser String Unit
eol = ((char '\r' *> char '\n') <|> char '\n') *> return unit

-- | Return the current parser position
getPosition :: forall a. Parser a Position
getPosition = ParserT $ \(PState { input: s, position: pos }) ->
  return { input: s, result: Right pos, consumed: true, position: pos }

-- | Ignore all whitespace until the EOL
chompRight :: Parser String Unit
chompRight = (many space) *> (eol <|> eof) *> return unit

-- | Chomp characters from the left
indent :: Int -> Parser String Unit
indent n = (for (List.range 1 n) (const space)) *> return unit

-- | Trace the current parser position
debugPosition = debug <$> getPosition

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


add GetStampRally

add GetStampRally

module GetStampRally (getStampRally) where

import Control.Monad.Aff (Aff)
import Control.Monad.Except (runExcept)
import Data.GetStampRallyResponse (GetStampRallyResponse)
import Data.Either (fromRight)
import Data.Foreign (F)
import Data.Foreign.Class (readJSON)
import Data.Options ((:=))
import Data.StrMap (fromFoldable) as StrMap
import Data.Tuple (Tuple(..))
import Fetch (HTTP, fetch)
import Fetch.Options (Method(..), headers, method, url) as FetchOptions
import Partial.Unsafe (unsafePartial)
import Prelude (($), (<>), bind, pure)

getStampRally :: forall eff
               . String
               -> String
               -> Aff (http :: HTTP | eff) GetStampRallyResponse
getStampRally stampRallyId token = do
  text <- fetch options
  let e = runExcept $ readJSON text :: F GetStampRallyResponse
  pure $ unsafePartial $ fromRight e
  where
    headers = StrMap.fromFoldable [ Tuple "Content-Type" "application/json"
                                  , Tuple "User-Agent" "rally-cli"
                                  , Tuple "Authorization" $ "Token token=\"" <> token <> "\""
                                  ]
    url = ( "https://api.rallyapp.jp/stamp_rallies/"
          <> stampRallyId
          <> "?view_type=admin"
          )
    options = FetchOptions.method := FetchOptions.GET
              <> FetchOptions.url := url
              <> FetchOptions.headers := headers

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


Add Interpolate module

Add Interpolate module

module Graphics.D3.Interpolate
  ( Interpolator()
  , makeInterpolator
  ) where

import Data.Foreign.EasyFFI

ffi = unsafeForeignFunction

foreign import data Interpolator :: * -> *

makeInterpolator :: forall a. (a -> a -> Number -> a) -> Interpolator a
makeInterpolator = ffi ["f"] "function (x, y) { return f(x)(y); }"

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


#483 Make it h1

#483 Make it h1


4.11.4

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/'


Add Stack for keeping track of application nodes

The Stack is always non-empty, which is why its representation is

  { top: Address, rest: List Address }

Every element of rest must point to an application node. top is either
another application node about to be unwound or another node type that
is being applied.

module Machine.Stack
  ( Stack
  , singleton
  , push
  , discard
  , replace
  , peek
  , fromList
  ) where

import Prelude

import Control.Monad.State (class MonadState, gets, modify_)
import Data.List (List(..), index)
import Data.Maybe (Maybe(..))
import Machine.Address (Address)

type Stack =
  { top :: Address
  , rest :: List Address
  }

singleton :: Address -> Stack
singleton top = { top, rest: Nil }

push :: forall s m. MonadState { stack :: Stack | s } m => Address -> m Unit
push address = do
  {top, rest} <- gets _.stack
  modify_ $ _ { stack = {top: address, rest: Cons top rest} }

discard :: forall s m. MonadState { stack :: Stack | s } m => m Unit
discard = do
  {rest} <- gets _.stack
  case rest of
    Cons y ys -> modify_ $ _ { stack = {top: y, rest: ys} }
    Nil -> pure unit

replace :: forall s m. MonadState { stack :: Stack | s } m => Address -> m Unit
replace address = do
  {rest} <- gets _.stack
  modify_ $ _ { stack = {top: address, rest} }

peek :: forall s m. MonadState { stack :: Stack | s } m => Int -> m (Maybe Address)
peek i = do
  {top, rest} <- gets _.stack
  pure $ index (Cons top rest) i

fromList :: List Address -> Maybe Stack
fromList = case _ of
  Nil -> Nothing
  Cons top rest -> Just {top, rest}

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


Added a test of put followed by fetching all habits.

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/'


Tweaked the test descriptions.

Tweaked the test descriptions.


Documentation link

Documentation link

-- | This module defines the interpreter for Insect.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Array ((:), fromFoldable, singleton)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (foldMap, intercalate)
import Data.List (sortBy, groupBy)
import Data.List.NonEmpty (head)
import Data.Maybe (Maybe(..))
import Data.String (toLower)
import Data.StrMap (lookup, insert, toList)
import Data.Tuple (fst, snd)

import Quantities (Quantity, UnificationError(..), pow, scalar', qNegate, qAdd,
                   qDivide, qMultiply, qSubtract, quantity, toScalar', sqrt,
                   convertTo, prettyPrint', fullSimplify, derivedUnit, acos,
                   asin, atan, sin, cos, tan, exp, ln, sinh, cosh, tanh, asinh,
                   acosh, atanh, ceil, floor, log10, round, isFinite,
                   toStandardUnit, unity, toString, baseRepresentation)

import Insect.Language (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..))
import Insect.Environment (Environment, initialEnvironment)
import Insect.Format (Markup)
import Insect.Format as F
import Insect.PrettyPrint (pretty, prettyQuantity)

-- | Types of errors that may appear during evaluation.
data EvalError
  = QUnificationError UnificationError
  | LookupError String
  | NumericalError

-- | A type synonym for error handling. A value of type `Expect Number` is
-- | expected to be a number but might also result in an evaluation error.
type Expect = Either EvalError

-- | Different kinds of messages that will be returned by the interpreter.
data MessageType = Value | ValueSet | Info | Error

-- | The output type of the interpreter.
data Message = Message MessageType Markup | MQuit | MClear

-- | Check if the numerical value of a quantity is finite, throw a
-- | `NumericalError` otherwise.
checkFinite ∷ Quantity → Expect Quantity
checkFinite q | isFinite q = pure q
              | otherwise  = Left NumericalError

-- | Apply a mathematical function to a physical quantity.
applyFunction ∷ Func → Quantity → Expect Quantity
applyFunction fn q = lmap QUnificationError $ (run fn) q
  where
    run Acos  = acos
    run Acosh = acosh
    run Asin  = asin
    run Asinh = asinh
    run Atan  = atan
    run Atanh = atanh
    run Ceil  = ceil
    run Cos   = cos
    run Cosh  = cosh
    run Exp   = exp
    run Floor = floor
    run Ln    = ln
    run Log10 = log10
    run Round = round
    run Sin   = sin
    run Sinh  = sinh
    run Sqrt  = sqrt >>> pure
    run Tan   = tan
    run Tanh  = tanh

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Scalar n)      = pure $ scalar' n
eval env (Unit u)        = pure $ quantity 1.0 u
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)
eval env (Negate x)      = qNegate <$> eval env x
eval env (Apply fn x)    = eval env x >>= applyFunction fn >>= checkFinite
eval env (BinOp op x y)  = do
  x' <- eval env x
  y' <- eval env y
  (run op) x' y' >>= checkFinite
  where
    run :: BinOp -> Quantity -> Quantity -> Expect Quantity
    run Sub       a b = qSubtract' a b
    run Add       a b = qAdd' a b
    run Mul       a b = pure (qMultiply a b)
    run Div       a b = pure (qDivide a b)
    run Pow       a b = pow a <$> toScalar'' b
    run ConvertTo a b = convertTo' a b

    wrap ∷ ∀ a. Either UnificationError a → Either EvalError a
    wrap = lmap QUnificationError

    qSubtract' q1 q2 = wrap (qSubtract q1 q2)
    qAdd' q1 q2 = wrap (qAdd q1 q2)
    toScalar'' q = wrap (toScalar' q)
    convertTo' source target = wrap (convertTo source (derivedUnit target))

-- | Render the error message for a unification error.
unificationErrorMessage ∷ UnificationError → Markup
unificationErrorMessage (UnificationError u1 u2) =
  if u1 == unity
    then scalarErr u2
    else
      if u2 == unity
        then scalarErr u1
        else
            [ F.error "  Unification error:", F.nl, F.nl
            , F.text "    Cannot unify unit ", F.unit (toString u1)
            ] <> baseRep u1 <>
            [ F.nl
            , F.text "            with unit ", F.unit (toString u2)
            ] <> baseRep u2
  where
    scalarErr u =
      [ F.error "  Unification error:", F.nl, F.nl
      , F.text "    Cannot convert quantity of unit "
      , F.unit (toString u)
      , F.text " to a ", F.unit "scalar"
      ]
    baseRep u =
      if fst (toStandardUnit u) == unity
        then []
        else F.text " (base units: " : usStrs <> [ F.text ")" ]
      where
        us = baseRepresentation u
        us' = sortBy (comparing toString) us
        usStrs = intercalate [ F.text "·" ] $
                   map (singleton <<< F.unit <<< toString) us'

-- | Get the error message for an evaluation error.
evalErrorMessage ∷ EvalError → Markup
evalErrorMessage (QUnificationError ue) =
  unificationErrorMessage ue
evalErrorMessage (LookupError name) =
  [ F.optional (F.text "  ")
  , F.error "Unknown identifier: "
  , F.ident name]
evalErrorMessage NumericalError =
  [ F.optional (F.text "  ")
  , F.error "Numerical error: "
  , F.text "division by zero or out-of-bounds error" ]

-- | Interpreter return type.
type Response = { msg ∷ Message, newEnv ∷ Environment }

-- | Show pretty-printed input and the error message.
errorWithInput ∷ Markup → Expression → Environment → EvalError → Response
errorWithInput prefix expr env err =
  { msg: Message Error $ (F.optional <$> F.text "  " : prefix <> pretty expr)
                         <> (F.optional <$> [ F.nl, F.nl ])
                         <> evalErrorMessage err
  , newEnv: env
  }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → Response
runInsect env (Expression e) =
  case (fullSimplify <$> eval env e) of
    Left evalErr → errorWithInput [] e env evalErr
    Right value →
      { msg: Message Value $    (F.optional <$> F.text "  " : pretty e)
                             <> (F.optional <$> [ F.nl, F.nl , F.text "   = " ])
                             <> prettyQuantity value
      , newEnv: insert "ans" value env
      }
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → errorWithInput [ F.ident n, F.text " = " ] v env evalErr
    Right value' →
      let value = fullSimplify value'
      in { msg: Message ValueSet $
                     (F.optional <$> [ F.text "  ", F.ident n, F.text " = " ])
                  <> prettyQuantity value
         , newEnv: insert n value env
         }
runInsect env (Command Help) = { msg: Message Info
  [ F.emph "insect", F.text " evaluates mathematical expressions that can", F.nl
  , F.text "involve physical quantities. You can start by trying", F.nl
  , F.text "one of these examples:", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "1920", F.text "/", F.val "16", F.text "*", F.val "9", F.text "             "
  , F.emph "  > ", F.function "sin", F.text "(", F.val "30", F.unit "deg", F.text ")", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "2", F.unit "min", F.text " + ", F.val "30", F.unit "s", F.text "            "
  , F.emph "  > ", F.val "6", F.unit "Mbit/s", F.text " * ", F.val "1.5", F.unit "h", F.text " -> ", F.unit "GB", F.val "", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.text "list", F.text "                  "
  , F.emph "  > ", F.ident "r", F.text " = ", F.val "80", F.unit "cm", F.nl
  , F.emph "  > ", F.val "40000", F.unit "km", F.text "/", F.ident "c", F.text " -> ", F.unit "ms", F.text "       "
  , F.emph "  > ", F.ident "pi", F.text " * ", F.ident "r", F.text "^", F.val "2", F.text " -> ", F.unit "m", F.text "^", F.val "2", F.nl
  , F.text "", F.nl
  , F.text "Full documentation: https://github.com/sharkdp/insect"
  ], newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    envTuples = sortBy (comparing (fst <<< prettyPrint' <<< snd)) $ toList env
    envGrouped = groupBy (\x y → snd x == snd y) envTuples
    envSorted = sortBy (comparing (toLower <<< fst <<< head)) envGrouped
    list = [ F.text "List of variables:", F.nl ] <> foldMap toLine envSorted
    toLine kvPairs =
         [ F.nl, F.text "  " ]
      <> identifiers
      <> [ F.text " = " ]
      <> prettyQuantity val
        where
          identifiers = fromFoldable $ intercalate [ F.text " = " ] $
                          (singleton <<< F.ident <<< fst) <$> kvPairs
          val = snd (head kvPairs)
runInsect env (Command Reset) =
  { msg: Message Info [F.text "Environment has been reset."]
  , newEnv: initialEnvironment }
runInsect env (Command Quit) = { msg: MQuit, newEnv: initialEnvironment }
runInsect env (Command Clear) = { msg: MClear, newEnv: env }

-- | This module defines the interpreter for Insect.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Array ((:), fromFoldable, singleton)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (foldMap, intercalate)
import Data.List (sortBy, groupBy)
import Data.List.NonEmpty (head)
import Data.Maybe (Maybe(..))
import Data.String (toLower)
import Data.StrMap (lookup, insert, toList)
import Data.Tuple (fst, snd)

import Quantities (Quantity, UnificationError(..), pow, scalar', qNegate, qAdd,
                   qDivide, qMultiply, qSubtract, quantity, toScalar', sqrt,
                   convertTo, prettyPrint', fullSimplify, derivedUnit, acos,
                   asin, atan, sin, cos, tan, exp, ln, sinh, cosh, tanh, asinh,
                   acosh, atanh, ceil, floor, log10, round, isFinite,
                   toStandardUnit, unity, toString, baseRepresentation)

import Insect.Language (Func(..), BinOp(..), Expression(..), Command(..),
                        Statement(..))
import Insect.Environment (Environment, initialEnvironment)
import Insect.Format (Markup)
import Insect.Format as F
import Insect.PrettyPrint (pretty, prettyQuantity)

-- | Types of errors that may appear during evaluation.
data EvalError
  = QUnificationError UnificationError
  | LookupError String
  | NumericalError

-- | A type synonym for error handling. A value of type `Expect Number` is
-- | expected to be a number but might also result in an evaluation error.
type Expect = Either EvalError

-- | Different kinds of messages that will be returned by the interpreter.
data MessageType = Value | ValueSet | Info | Error

-- | The output type of the interpreter.
data Message = Message MessageType Markup | MQuit | MClear

-- | Check if the numerical value of a quantity is finite, throw a
-- | `NumericalError` otherwise.
checkFinite ∷ Quantity → Expect Quantity
checkFinite q | isFinite q = pure q
              | otherwise  = Left NumericalError

-- | Apply a mathematical function to a physical quantity.
applyFunction ∷ Func → Quantity → Expect Quantity
applyFunction fn q = lmap QUnificationError $ (run fn) q
  where
    run Acos  = acos
    run Acosh = acosh
    run Asin  = asin
    run Asinh = asinh
    run Atan  = atan
    run Atanh = atanh
    run Ceil  = ceil
    run Cos   = cos
    run Cosh  = cosh
    run Exp   = exp
    run Floor = floor
    run Ln    = ln
    run Log10 = log10
    run Round = round
    run Sin   = sin
    run Sinh  = sinh
    run Sqrt  = sqrt >>> pure
    run Tan   = tan
    run Tanh  = tanh

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Scalar n)      = pure $ scalar' n
eval env (Unit u)        = pure $ quantity 1.0 u
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)
eval env (Negate x)      = qNegate <$> eval env x
eval env (Apply fn x)    = eval env x >>= applyFunction fn >>= checkFinite
eval env (BinOp op x y)  = do
  x' <- eval env x
  y' <- eval env y
  (run op) x' y' >>= checkFinite
  where
    run :: BinOp -> Quantity -> Quantity -> Expect Quantity
    run Sub       a b = qSubtract' a b
    run Add       a b = qAdd' a b
    run Mul       a b = pure (qMultiply a b)
    run Div       a b = pure (qDivide a b)
    run Pow       a b = pow a <$> toScalar'' b
    run ConvertTo a b = convertTo' a b

    wrap ∷ ∀ a. Either UnificationError a → Either EvalError a
    wrap = lmap QUnificationError

    qSubtract' q1 q2 = wrap (qSubtract q1 q2)
    qAdd' q1 q2 = wrap (qAdd q1 q2)
    toScalar'' q = wrap (toScalar' q)
    convertTo' source target = wrap (convertTo source (derivedUnit target))

-- | Render the error message for a unification error.
unificationErrorMessage ∷ UnificationError → Markup
unificationErrorMessage (UnificationError u1 u2) =
  if u1 == unity
    then scalarErr u2
    else
      if u2 == unity
        then scalarErr u1
        else
            [ F.error "  Unification error:", F.nl, F.nl
            , F.text "    Cannot unify unit ", F.unit (toString u1)
            ] <> baseRep u1 <>
            [ F.nl
            , F.text "            with unit ", F.unit (toString u2)
            ] <> baseRep u2
  where
    scalarErr u =
      [ F.error "  Unification error:", F.nl, F.nl
      , F.text "    Cannot convert quantity of unit "
      , F.unit (toString u)
      , F.text " to a ", F.unit "scalar"
      ]
    baseRep u =
      if fst (toStandardUnit u) == unity
        then []
        else F.text " (base units: " : usStrs <> [ F.text ")" ]
      where
        us = baseRepresentation u
        us' = sortBy (comparing toString) us
        usStrs = intercalate [ F.text "·" ] $
                   map (singleton <<< F.unit <<< toString) us'

-- | Get the error message for an evaluation error.
evalErrorMessage ∷ EvalError → Markup
evalErrorMessage (QUnificationError ue) =
  unificationErrorMessage ue
evalErrorMessage (LookupError name) =
  [ F.optional (F.text "  ")
  , F.error "Unknown identifier: "
  , F.ident name]
evalErrorMessage NumericalError =
  [ F.optional (F.text "  ")
  , F.error "Numerical error: "
  , F.text "division by zero or out-of-bounds error" ]

-- | Interpreter return type.
type Response = { msg ∷ Message, newEnv ∷ Environment }

-- | Show pretty-printed input and the error message.
errorWithInput ∷ Markup → Expression → Environment → EvalError → Response
errorWithInput prefix expr env err =
  { msg: Message Error $ (F.optional <$> F.text "  " : prefix <> pretty expr)
                         <> (F.optional <$> [ F.nl, F.nl ])
                         <> evalErrorMessage err
  , newEnv: env
  }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → Response
runInsect env (Expression e) =
  case (fullSimplify <$> eval env e) of
    Left evalErr → errorWithInput [] e env evalErr
    Right value →
      { msg: Message Value $    (F.optional <$> F.text "  " : pretty e)
                             <> (F.optional <$> [ F.nl, F.nl , F.text "   = " ])
                             <> prettyQuantity value
      , newEnv: insert "ans" value env
      }
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → errorWithInput [ F.ident n, F.text " = " ] v env evalErr
    Right value' →
      let value = fullSimplify value'
      in { msg: Message ValueSet $
                     (F.optional <$> [ F.text "  ", F.ident n, F.text " = " ])
                  <> prettyQuantity value
         , newEnv: insert n value env
         }
runInsect env (Command Help) = { msg: Message Info
  [ F.emph "insect", F.text " evaluates mathematical expressions that can", F.nl
  , F.text "involve physical quantities. You can start by trying", F.nl
  , F.text "one of these examples:", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "1920", F.text "/", F.val "16", F.text "*", F.val "9", F.text "             "
  , F.emph "  > ", F.function "sin", F.text "(", F.val "30", F.unit "deg", F.text ")", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.val "2", F.unit "min", F.text " + ", F.val "30", F.unit "s", F.text "            "
  , F.emph "  > ", F.val "6", F.unit "Mbit/s", F.text " * ", F.val "1.5", F.unit "h", F.text " -> ", F.unit "GB", F.val "", F.nl
  , F.text "", F.nl
  , F.emph "  > ", F.text "list", F.text "                  "
  , F.emph "  > ", F.ident "r", F.text " = ", F.val "80", F.unit "cm", F.nl
  , F.emph "  > ", F.val "40000", F.unit "km", F.text "/", F.ident "c", F.text " -> ", F.unit "ms", F.text "       "
  , F.emph "  > ", F.ident "pi", F.text " * ", F.ident "r", F.text "^", F.val "2", F.text " -> ", F.unit "m", F.text "^", F.val "2", F.nl
  , F.text "", F.nl
  , F.text "More information: https://github.com/sharkdp/insect"
  ], newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    envTuples = sortBy (comparing (fst <<< prettyPrint' <<< snd)) $ toList env
    envGrouped = groupBy (\x y → snd x == snd y) envTuples
    envSorted = sortBy (comparing (toLower <<< fst <<< head)) envGrouped
    list = [ F.text "List of variables:", F.nl ] <> foldMap toLine envSorted
    toLine kvPairs =
         [ F.nl, F.text "  " ]
      <> identifiers
      <> [ F.text " = " ]
      <> prettyQuantity val
        where
          identifiers = fromFoldable $ intercalate [ F.text " = " ] $
                          (singleton <<< F.ident <<< fst) <$> kvPairs
          val = snd (head kvPairs)
runInsect env (Command Reset) =
  { msg: Message Info [F.text "Environment has been reset."]
  , newEnv: initialEnvironment }
runInsect env (Command Quit) = { msg: MQuit, newEnv: initialEnvironment }
runInsect env (Command Clear) = { msg: MClear, newEnv: env }


Added missing Bootstrap.purs

Added missing Bootstrap.purs

module Pux.Html.Attributes.Bootstrap where

import Pux.Html (Attribute)
import Pux.Html.Attributes (attr)

dataToggle :: forall a. String -> Attribute a
dataToggle = attr "data-toggle"

dataTarget :: forall a. String -> Attribute a
dataTarget = attr "data-target"

-- Non bootstrap:

integrity :: forall a. String -> Attribute a
integrity = attr "integrity"

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


solution for Day2 Part1

solution for Day2 Part1

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/michaelsbradleyjr/advent-of-code.git/'


Test for hidden type errors

Test for hidden type errors

-- exporting `a` should fail as `A` is hidden
module Foo (B(..), a, b) where

  data A = A
  data B = B

  a = A
  b = B

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


Use simplifyUnit to get nicer outputs

Use simplifyUnit to get nicer outputs

-- | This module defines the interpreter for the Insect language.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , Environment
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.StrMap (StrMap, lookup, insert)
import Data.Bifunctor (lmap)

import Quantities (Quantity, DerivedUnit, UnificationError, asValueIn, pow,
                   qNegate, qAdd, qDivide, qMultiply, qSubtract, quantity,
                   unity, convert, errorMessage, prettyPrint, scalar,
                   simplifyUnit)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..))

-- | The types of errors that may appear during evaluation
data EvalError
  = UnificationError UnificationError
  | LookupError String

type Expect = Either EvalError

data MessageType = Value | Info | Error

data Message = Message MessageType String

type Environment = StrMap Quantity

-- A few helper functions
qSubtract' ∷ Quantity → Quantity → Expect Quantity
qSubtract' q1 q2 = lmap UnificationError (qSubtract q1 q2)

qAdd' ∷ Quantity → Quantity → Expect Quantity
qAdd' q1 q2 = lmap UnificationError (qAdd q1 q2)

asScalar ∷ Quantity → Expect Number
asScalar q = lmap UnificationError (q `asValueIn` unity)

convert' ∷ DerivedUnit → Quantity → Expect Quantity
convert' d q = lmap UnificationError (convert d q)

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Q n u)         = pure $ quantity n u
eval env (Negate x)      = qNegate <$> eval env x
eval env (BinOp Sub x y) = join $ qSubtract' <$> eval env x <*> eval env y
eval env (BinOp Add x y) = join $ qAdd'      <$> eval env x <*> eval env y
eval env (BinOp Mul x y) =        qMultiply  <$> eval env x <*> eval env y
eval env (BinOp Div x y) =        qDivide    <$> eval env x <*> eval env y
eval env (BinOp Pow x y) = do
  base ← eval env x
  exp ← eval env y
  expNumber ← asScalar exp
  pure $ base `pow` expNumber
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)

evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

message ∷ Environment → Expect Quantity → { msg ∷ Message, newEnv ∷ Environment }
message env (Left e) = { msg: Message Error (evalErrorMessage e), newEnv: env }
message env (Right q) = { msg: Message Value (prettyPrint q), newEnv: env }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → { msg ∷ Message, newEnv ∷ Environment }
runInsect env (Expression e) = message env (simplifyUnit <$> eval env e)
runInsect env (Conversion e u) = message env (eval env e >>= convert' u)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message env (Left evalErr)
    Right value → message (insert n value env) (Right (simplifyUnit value))
runInsect env (Command Help) = { msg: Message Info (intercalate "\n"
  [ "INSECT is a command-line scientific calculator."
  , ""
  , "It understands simple calculations like 1920 / 16 · 9"
  , "as well as mathematical expressions involving physical"
  , "quantities."
  , ""
  , "You can start by trying one of these examples:"
  , ""
  , "> 1920/16·9"
  , "> 2min + 30s"
  , "> 60mph -> m/s"
  , "> 6Mbps*1.5h -> Gb"
  ]), newEnv : env }
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }

-- | This module defines the interpreter for the Insect language.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , Environment
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.StrMap (StrMap, lookup, insert)
import Data.Bifunctor (lmap)

import Quantities (Quantity, DerivedUnit, UnificationError, asValueIn, pow,
                   qNegate, qAdd, qDivide, qMultiply, qSubtract, quantity,
                   unity, convert, errorMessage, prettyPrint, scalar)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..))

-- | The types of errors that may appear during evaluation
data EvalError
  = UnificationError UnificationError
  | LookupError String

type Expect = Either EvalError

data MessageType = Value | Info | Error

data Message = Message MessageType String

type Environment = StrMap Quantity

-- A few helper functions
qSubtract' ∷ Quantity → Quantity → Expect Quantity
qSubtract' q1 q2 = lmap UnificationError (qSubtract q1 q2)

qAdd' ∷ Quantity → Quantity → Expect Quantity
qAdd' q1 q2 = lmap UnificationError (qAdd q1 q2)

asScalar ∷ Quantity → Expect Number
asScalar q = lmap UnificationError (q `asValueIn` unity)

convert' ∷ DerivedUnit → Quantity → Expect Quantity
convert' d q = lmap UnificationError (convert d q)

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Q n u)         = pure $ quantity n u
eval env (Negate x)      = qNegate <$> eval env x
eval env (BinOp Sub x y) = join $ qSubtract' <$> eval env x <*> eval env y
eval env (BinOp Add x y) = join $ qAdd'      <$> eval env x <*> eval env y
eval env (BinOp Mul x y) =        qMultiply  <$> eval env x <*> eval env y
eval env (BinOp Div x y) =        qDivide    <$> eval env x <*> eval env y
eval env (BinOp Pow x y) = do
  base ← eval env x
  exp ← eval env y
  expNumber ← asScalar exp
  pure $ base `pow` expNumber
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)

evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

message ∷ Environment → Expect Quantity → { msg ∷ Message, newEnv ∷ Environment }
message env (Left e) = { msg: Message Error (evalErrorMessage e), newEnv: env }
message env (Right q) = { msg: Message Value (prettyPrint q), newEnv: env }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → { msg ∷ Message, newEnv ∷ Environment }
runInsect env (Expression e) = message env (eval env e)
runInsect env (Conversion e u) = message env (eval env e >>= convert' u)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message env (Left evalErr)
    Right value → message (insert n value env) (Right value)
runInsect env (Command Help) = { msg: Message Info (intercalate "\n"
  [ "INSECT is a command-line scientific calculator."
  , ""
  , "It understands simple calculations like 1920 / 16 · 9"
  , "as well as mathematical expressions involving physical"
  , "quantities."
  , ""
  , "You can start by trying one of these examples:"
  , ""
  , "> 1920/16·9"
  , "> 2min + 30s"
  , "> 60mph -> m/s"
  , "> 6Mbps*1.5h -> Gb"
  ]), newEnv : env }
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }


Most of Language.PureScript.TypeChecker.Monad

module Language.PureScript.TypeChecker.Monad where

import Language.PureScript.Declarations (canonicalizeDictionary)
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types

import Data.Array (map)
import Data.Either
import Data.Maybe
import Data.Tuple

import Control.Monad.Error
import Control.Monad.Error.Class
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.State.Trans
import Control.Monad.Trans
import Control.Monad.Unify

import qualified Data.Map as M

-- |
-- Temporarily bind a collection of names to values
--
bindNames :: forall m a. (Monad m, MonadState CheckState m) => M.Map (Tuple ModuleName Ident) (Tuple Type NameKind) -> m a -> m a
bindNames newNames action = do
  CheckState orig <- get
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { names = newNames `M.union` (envObj st.env).names } }
  a <- action
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { names = (envObj orig.env).names } }
  return a

-- |
-- Temporarily bind a collection of names to types
--
bindTypes :: forall m a. (Monad m, MonadState CheckState m) => M.Map (Qualified ProperName) (Tuple Kind TypeKind) -> m a -> m a
bindTypes newNames action = do
  CheckState orig <- get
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { types = newNames `M.union` (envObj st.env).types } }
  a <- action
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { types = (envObj orig.env).types } }
  return a
-- |
-- Temporarily make a collection of type class dictionaries available
--
withTypeClassDictionaries :: forall m a. (Monad m, MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
withTypeClassDictionaries entries action = do
  CheckState orig <- get
  let mentries = M.fromList $ flip map entries $ \entry -> case entry of
                     TypeClassDictionaryInScope { name = (Qualified mn _) } ->
                       Tuple (Tuple (canonicalizeDictionary entry) mn) entry
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { typeClassDictionaries = (envObj st.env).typeClassDictionaries `M.union` mentries } }
  a <- action
  modify $ \(CheckState st) -> CheckState $ st { env = Environment $ (envObj st.env) { typeClassDictionaries = (envObj orig.env).typeClassDictionaries } }
  return a

-- |
-- Get the currently available list of type class dictionaries
--
getTypeClassDictionaries :: forall m. (Monad m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
getTypeClassDictionaries = M.values <<< (\(CheckState st) -> (envObj st.env).typeClassDictionaries) <$> get

-- |
-- Temporarily bind a collection of names to local variables
--
bindLocalVariables :: forall m a. (Monad m, MonadState CheckState m) => ModuleName -> [Tuple Ident Type] -> m a -> m a
bindLocalVariables moduleName bindings =
  bindNames (M.fromList $ flip map bindings $ \(Tuple name ty) -> Tuple (Tuple moduleName name) (Tuple ty LocalVariable))

-- |
-- Temporarily bind a collection of names to local type variables
--
bindLocalTypeVariables :: forall m a. (Monad m, MonadState CheckState m) => ModuleName -> [Tuple ProperName Kind] -> m a -> m a
bindLocalTypeVariables moduleName bindings =
  bindTypes (M.fromList $ flip map bindings $ \(Tuple pn kind) -> Tuple (Qualified (Just moduleName) pn) (Tuple kind LocalTypeVariable))

{-
-- |
-- Lookup the type of a value by name in the @Environment@
--
lookupVariable :: forall e m. (Error e, Monad m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
lookupVariable currentModule (Qualified moduleName var) = do
  Environment env <- getEnv
  case M.lookup (Tuple (fromMaybe currentModule moduleName) var) env.names of
    Nothing -> throwError $ strMsg $ show var ++ " is undefined"
    Just (Tuple ty _) -> return ty

-- |
-- Lookup the kind of a type by name in the @Environment@
--
lookupTypeVariable :: forall e m. (Error e, Monad m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
lookupTypeVariable currentModule (Qualified moduleName name) = do
  env <- getEnv
  case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
    Nothing -> throwError $ strMsg $ "Type variable " ++ show name ++ " is undefined"
    Just (Tuple k _) -> return k
-}
-- |
-- State required for type checking:
--
data CheckState = CheckState {
  -- |
  -- The current @Environment@
  --
    env :: Environment
  -- |
  -- The next fresh unification variable name
  --
  , nextVar :: Number
  -- |
  -- The next type class dictionary name
  --
  , nextDictName :: Number
  -- |
  -- The current module
  --
  , currentModule :: Maybe ModuleName
  }

-- |
-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
--
data Check a = Check (StateT CheckState (Either ErrorStack) a)
-- TODO: deriving MonadPlus

unCheck :: forall a. Check a -> StateT CheckState (Either ErrorStack) a
unCheck (Check x) = x

instance functorCheck :: Functor Check where
  (<$>) f (Check x) = Check (f <$> x)

instance applyCheck :: Apply Check where
  (<*>) (Check f) (Check x) = Check (f <*> x)

instance applicativeCheck :: Applicative Check where
  pure a = Check (pure a)

instance bindCheck :: Bind Check where
  (>>=) (Check x) f = Check (x >>= unCheck <<< f)

instance monadCheck :: Monad Check

instance monadErrorCheck :: MonadError ErrorStack Check where
  throwError = Check <<< throwError
  catchError e f = Check $ catchError (unCheck e) (unCheck <<< f)

instance monadStateCheck :: MonadState CheckState Check where
  state = Check <<< state

-- |
-- Get the current @Environment@
--
getEnv :: forall m. (Monad m, MonadState CheckState m) => m Environment
getEnv = (\(CheckState st) -> st.env) <$> get

-- |
-- Update the @Environment@
--
putEnv :: forall m. (Monad m, MonadState CheckState m) => Environment -> m {}
putEnv env = modify $ \(CheckState st) -> CheckState $ st { env = env }

-- |
-- Modify the @Environment@
--
modifyEnv :: forall m. (Monad m, MonadState CheckState m) => (Environment -> Environment) -> m {}
modifyEnv f = modify (\(CheckState st) -> CheckState $ st { env = f st.env })

-- |
-- Run a computation in the Check monad, starting with an empty @Environment@
--
runCheck :: forall a. Options -> Check a -> Either String (Tuple a Environment)
runCheck opts = runCheck' opts initEnvironment

-- |
-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
--
runCheck' :: forall a. Options -> Environment -> Check a -> Either String (Tuple a Environment)
runCheck' (Options o) env c = stringifyErrorStack o.optionsVerboseErrors $ do
  (Tuple a (CheckState st)) <- flip runStateT (CheckState { env: env, nextVar: 0, nextDictName: 0, currentModule: Nothing }) $ unCheck c
  return $ Tuple a (st.env)

-- |
-- Make an assertion, failing with an error message
--
guardWith :: forall e m. (Monad m, MonadError e m) => e -> Boolean -> m {}
guardWith _ true = return {}
guardWith e false = throwError e

-- |
-- Generate new type class dictionary name
--
freshDictionaryName :: Check Number
freshDictionaryName = do
  n <- (\(CheckState st) -> st.nextDictName) <$> get
  modify $ \(CheckState st) -> CheckState $ st { nextDictName = st.nextDictName + 1 }
  return n

-- |
-- Lift a computation in the @Check@ monad into the substitution monad.
--
liftCheck :: forall a t. Check a -> UnifyT t Check a
liftCheck = UnifyT <<< lift

-- |
-- Run a computation in the substitution monad, generating a return value and the final substitution.
--
liftUnify :: forall t a. (Partial t) => UnifyT t Check a -> Check (Tuple a (Substitution t))
liftUnify unify = do
  CheckState st <- get
  Tuple a (UnifyState ust) <- runUnify (UnifyState $ (unifyStateObj defaultUnifyState) { unifyNextVar = st.nextVar }) unify
  modify $ \(CheckState st') -> CheckState $ st' { nextVar = ust.unifyNextVar }
  return $ Tuple a ust.unifyCurrentSubstitution

error: pathspec 'src/Language/PureScript/TypeChecker/Monad.purs' did not match any file(s) known to git


Port Language.PureScript.CodeGen.Common

Port Language.PureScript.CodeGen.Common

module Language.PureScript.CodeGen.Common where

import Data.Array (concatMap, elem, map)
import Data.Foldable (all, foldMap)
import Data.Monoid ()
import Data.String (charCodeAt, joinWith, split)
import Data.String.Regex (Regex(..), regex, test)
import Language.PureScript.Names

-- |
-- Convert an Ident into a valid Javascript identifier:
--
--  * Alphanumeric characters are kept unmodified.
--
--  * Reserved javascript identifiers are prefixed with '$$'.
--
--  * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
--
identToJs :: Ident -> String
identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
identToJs (Ident name) = foldMap identCharToString (split name "")
identToJs (Op op) = foldMap identCharToString (split op "")

-- |
-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
-- ordinal value.
--
identCharToString :: String -> String
identCharToString c | test rxAlphaNum c = c
identCharToString "_" = "_"
identCharToString "." = "$dot"
identCharToString "$" = "$dollar"
identCharToString "~" = "$tilde"
identCharToString "=" = "$eq"
identCharToString "<" = "$less"
identCharToString ">" = "$greater"
identCharToString "!" = "$bang"
identCharToString "#" = "$hash"
identCharToString "%" = "$percent"
identCharToString "^" = "$up"
identCharToString "&" = "$amp"
identCharToString "|" = "$bar"
identCharToString "*" = "$times"
identCharToString "/" = "$div"
identCharToString "+" = "$plus"
identCharToString "-" = "$minus"
identCharToString ":" = "$colon"
identCharToString "\\" = "$bslash"
identCharToString "?" = "$qmark"
identCharToString "@" = "$at"
identCharToString "\'" = "$prime"
identCharToString c = "$" ++ show (charCodeAt 0 c)

-- |
-- Checks whether an identifier name is reserved in Javascript.
--
nameIsJsReserved :: String -> Boolean
nameIsJsReserved name =
  name `elem` [ "abstract"
              , "arguments"
              , "boolean"
              , "break"
              , "byte"
              , "case"
              , "catch"
              , "char"
              , "class"
              , "const"
              , "continue"
              , "debugger"
              , "default"
              , "delete"
              , "do"
              , "double"
              , "else"
              , "enum"
              , "eval"
              , "export"
              , "extends"
              , "final"
              , "finally"
              , "float"
              , "for"
              , "function"
              , "goto"
              , "if"
              , "implements"
              , "import"
              , "in"
              , "instanceof"
              , "int"
              , "interface"
              , "let"
              , "long"
              , "native"
              , "new"
              , "null"
              , "package"
              , "private"
              , "protected"
              , "public"
              , "return"
              , "short"
              , "static"
              , "super"
              , "switch"
              , "synchronized"
              , "this"
              , "throw"
              , "throws"
              , "transient"
              , "try"
              , "typeof"
              , "var"
              , "void"
              , "volatile"
              , "while"
              , "with"
              , "yield" ]

-- |
-- Test if a string is a valid JS identifier (may return false negatives)
--
isIdent :: String -> Boolean
isIdent = test rxIdent

moduleNameToJs :: ModuleName -> String
moduleNameToJs (ModuleName pns) = joinWith "_" (runProperName `map` pns)

rxAlphaNum :: Regex
rxAlphaNum = regex "[a-z0-9]" "i"

rxIdent :: Regex
rxIdent = regex "^[a-z][a-z0-9]+$" "i"

error: pathspec 'src/Language/PureScript/CodeGen/Common.purs' did not match any file(s) known to git


4.7.1 4.7.2

4.7.1 4.7.2


Added lenses for server types.

Added lenses for server types.

module Gonimo.Server.Types.Lenses where

import Gonimo.Server.Types
import Data.Either as Either
import Data.Lens as Lens
import Prelude as Prelude
import Gonimo.Types (Secret(Secret))

_GonimoSecret :: Lens.PrismP AuthToken Secret
_GonimoSecret = Lens.prism GonimoSecret unwrap
  where
    unwrap (GonimoSecret x) = Either.Right x
    unwrap y = Either.Left y

_Tea :: Lens.PrismP Coffee Prelude.Unit
_Tea = Lens.prism (Prelude.const Tea) unwrap
  where
    unwrap Tea = Either.Right Prelude.unit
    unwrap y = Either.Left y

_EmailInvitation :: Lens.PrismP InvitationDelivery String
_EmailInvitation = Lens.prism EmailInvitation unwrap
  where
    unwrap (EmailInvitation x) = Either.Right x
    unwrap y = Either.Left y

_OtherDelivery :: Lens.PrismP InvitationDelivery Prelude.Unit
_OtherDelivery = Lens.prism (Prelude.const OtherDelivery) unwrap
  where
    unwrap OtherDelivery = Either.Right Prelude.unit
    unwrap y = Either.Left y

_NoBaby :: Lens.PrismP DeviceType Prelude.Unit
_NoBaby = Lens.prism (Prelude.const NoBaby) unwrap
  where
    unwrap NoBaby = Either.Right Prelude.unit
    unwrap y = Either.Left y

_Baby :: Lens.PrismP DeviceType String
_Baby = Lens.prism Baby unwrap
  where
    unwrap (Baby x) = Either.Right x
    unwrap y = Either.Left y

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


Undo Redo mixin, fix #8

Undo Redo mixin, fix #8

module Halogen.Mixin.UndoRedo
  ( UndoRedoInput(..)
  , UndoRedoState()

  , canUndo
  , canRedo
  , getState
  , undoRedoState

  , withUndo
  ) where

import Data.Maybe
import Data.Tuple

data Stack a = Empty | Push a (Stack a)

pop :: forall a. Stack a -> Maybe (Tuple a (Stack a))
pop (Push a s) = Just (Tuple a s)
pop Empty = Nothing

depth :: forall a. Stack a -> Number
depth Empty = 0
depth (Push _ s) = 1 + depth s

null :: forall a. Stack a -> Boolean
null Empty = true
null _ = false

-- | Adds two new input types:
-- |
-- | - `Undo` - move to the previous state
-- | - `Redo` - move to the next state
data UndoRedoInput i = Undo | Redo | Input i

-- | Modifies the state type to include its _past_ and _future_.
data UndoRedoState s = UndoRedoState (Stack s) s (Stack s)

-- | `true` if the state supports the undo operation.
canUndo :: forall s. UndoRedoState s -> Boolean
canUndo (UndoRedoState past _ _) = not (null past)

-- | `true` if the state supports the redo operation.
canRedo :: forall s. UndoRedoState s -> Boolean
canRedo (UndoRedoState _ _ future) = not (null future)

-- | Get the state at the current time
getState :: forall s. UndoRedoState s -> s
getState (UndoRedoState _ s _) = s

-- | Create a state with no past and no future
undoRedoState :: forall s. s -> UndoRedoState s
undoRedoState s = UndoRedoState Empty s Empty

-- | Lift a step function to support the undo and redo operations.
-- |
-- | The view should use the `canUndo` and `canRedo` functions to determine whether or not
-- | to enable the corresponding controls.
withUndo :: forall s i. (s -> i -> s) -> UndoRedoState s -> UndoRedoInput i -> UndoRedoState s
withUndo _ st@(UndoRedoState past s future) Undo = fromMaybe st $ do
  Tuple prev rest <- pop past
  return $ UndoRedoState rest prev (Push s future)
withUndo _ st@(UndoRedoState past s future) Redo = fromMaybe st $ do
  Tuple next rest <- pop future
  return $ UndoRedoState (Push s past) next rest
withUndo f (UndoRedoState past s _) (Input i) = UndoRedoState (Push s past) (f s i) Empty

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


Add super basic Modal component

Add super basic Modal component

Only accepts a body child and a dismiss handler for now

module Components.Modal
  ( new
  ) where

import Lambda.Prelude

import Components.Overlay as Overlay
import Components.Level (Level)
import React.Basic (JSX)
import React.Basic.DOM as R
import React.Basic.DOM.Events (stopPropagation)
import React.Basic.Events (handler_, handler)
import React.Basic.Hooks (Component, component)

type Props =
  { level :: Level
  , title :: String
  , dismiss :: Effect Unit
  , children :: Array JSX
  }

new :: Component Props
new = do
  overlay <- Overlay.new
  component "Modal" \{ level, title, dismiss, children } ->
    pure $ overlay
      { dismiss: Just dismiss
      , children:
        [ R.div
          { className: fold
            [ "panel panel-"
            , show level
            , " overlay-modal"
            ]
          , onClick: handler stopPropagation $ const $ pure unit
          , children:
            [ R.div
              { className: "panel-heading"
              , children:
                [ R.h3
                  { className: "panel-title"
                  , children:
                    [ R.span
                      { className: "cursor-pointer glyphicon glyphicon-remove pull-right"
                      , onClick: handler_ dismiss
                      }
                    , R.text title
                    ]
                  }
                ]
              }
            , R.div
              { className: "panel-body"
              , children
              }
            ]
          }
        ]
      }

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


Add (|.) operator

Add (|.) operator

Just a synonym for (>>=) but it makes writing in the "fluid interface" style
more visually pleasant

module Graphics.D3.Base
  ( DOM()
  , D3Eff()
  , (|.)
  , void
  ) where

import Control.Monad.Eff

-- The type of effects having to do with observing and modifying the DOM
foreign import data DOM :: !

type D3Eff e a = Eff (dom :: DOM | e) a

-- Syntactic sugar to make chained monadic statements look similar to the
-- "fluid interface" style of chained method calls in JavaScript
(|.) = (>>=)

-- Remove this once it's available in Prelude
void :: forall f a. (Functor f) => f a -> f Unit
void fa = const unit <$> fa

module Graphics.D3.Base
  ( DOM()
  , D3Eff()
  , void
  ) where

import Control.Monad.Eff

-- The type of effects having to do with observing and modifying the DOM
foreign import data DOM :: !

type D3Eff e a = Eff (dom :: DOM | e) a

-- Remove this once it's available in Prelude
void :: forall f a. (Functor f) => f a -> f Unit
void fa = const unit <$> fa