Add usage example

Add usage example

module Main where

import Prelude
import WebSocket
import Control.Monad.Eff.Console
import Control.Monad.Eff (Eff ())
import Control.Monad.Trans (lift)
import Data.Either (Either (Left, Right))

main :: forall eff. Eff (ws :: WS, console :: CONSOLE | eff) Unit
main = do
  log "START"
  runWebSocket $ do
    result <- withWebSocket config handlers
    case result of
         Right _ -> output "DONE"
         Left err -> output err

config =
  { uri: "ws://127.0.0.1:9001"
  , protocols: []
  }

handlers :: forall eff. WebSocketHandler (console :: CONSOLE | eff)
handlers s = (defaultHandlers s)
  { onOpen = onOpenHandler
  , onMessage = onMessageHandler
  }

onOpenHandler :: forall eff. WithWebSocket (console :: CONSOLE | eff) Unit
onOpenHandler = log "OPEN"

onMessageHandler :: forall eff. String -> WithWebSocket (console :: CONSOLE | eff) Unit
onMessageHandler msg = log msg

output :: forall eff. String -> WebSocket (console :: CONSOLE | eff) Unit
output = lift <<< log

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


Language.PureScript.TypeChecker.Kinds

Language.PureScript.TypeChecker.Kinds

module Language.PureScript.TypeChecker.Kinds
  ( kindOf
  , kindsOf
  , kindsOfAll
  ) where

import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Pretty.Kinds
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.Types

import Control.Monad (replicateM)
import Control.Monad.Error
import Control.Monad.Error.Class
import Control.Monad.Error.Proxy
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.Trans
import Control.Monad.Unify

import Data.Array (length, map, zipWith)
import Data.Array.Unsafe (head)
import Data.Foldable (foldr, foldl, for_)
import Data.Maybe
import Data.Monoid
import Data.Traversable (traverse, zipWithA)
import Data.Tuple
import Data.Tuple3
import qualified Data.Map as M

instance partialKind :: Partial Kind where
  unknown = KUnknown
  isUnknown (KUnknown u) = Just u
  isUnknown _ = Nothing
  unknowns = everythingOnKinds (++) go
    where
    go (KUnknown u) = [u]
    go _ = []
  ($?) sub = everywhereOnKinds go
    where
    go t@(KUnknown u) = case M.lookup u (runSubstitution sub) of
                          Nothing -> t
                          Just t' -> t'
    go other = other

unifyError = WithErrorType :: WithErrorType ErrorStack

instance unifiableCheckKind :: Unifiable Check Kind where
  (=?=) (KUnknown u1) (KUnknown u2) | u1 == u2 = return {}
  (=?=) (KUnknown u) k = substitute unifyError u k
  (=?=) k (KUnknown u) = substitute unifyError u k
  (=?=) Star Star = return {}
  (=?=) Bang Bang = return {}
  (=?=) (Row k1) (Row k2) = k1 =?= k2
  (=?=) (FunKind k1 k2) (FunKind k3 k4) = do
    k1 =?= k3
    k2 =?= k4
  (=?=) k1 k2 = UnifyT $ lift $ throwError $ withErrorType unifyError $ strMsg $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."

-- |
-- Infer the kind of a single type
--
kindOf :: ModuleName -> Type -> Check Kind
kindOf _ ty =
  rethrow (\x -> mkErrorStack "Error checking kind" (Just (TypeError ty)) <> x) $
    (<$>) tidyUp <<< liftUnify $ starIfUnknown <$> infer ty
  where
  tidyUp (Tuple k sub) = sub $? k

-- |
-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
--
kindsOf :: Boolean -> ModuleName -> ProperName -> [String] -> [Type] -> Check Kind
kindsOf isData moduleName name args ts = (<$>) tidyUp <<< liftUnify $ do
  tyCon <- fresh
  kargs <- replicateM (length args) fresh
  let dict = (Tuple name tyCon) : zipWith (\arg kind -> (Tuple arg kind)) (map ProperName args) kargs
  bindLocalTypeVariables moduleName dict $ solveTypes isData ts kargs tyCon
  where
  tidyUp (Tuple k sub) = starIfUnknown (sub $? k)

-- |
-- Simultaneously infer the kinds of several mutually recursive type constructors
--
kindsOfAll :: ModuleName -> [Tuple3 ProperName [String] Type] -> [Tuple3 ProperName [String] [Type]] -> Check (Tuple [Kind] [Kind])
kindsOfAll moduleName syns tys = (<$>) tidyUp <<< liftUnify $ do
  synVars <- replicateM (length syns) fresh
  let dict = zipWith (\(Tuple3 name _ _) var -> (Tuple name var)) syns synVars
  bindLocalTypeVariables moduleName dict $ do
    tyCons <- replicateM (length tys) fresh
    let dict' = zipWith (\(Tuple3 name _ _) tyCon -> (Tuple name tyCon)) tys tyCons
    bindLocalTypeVariables moduleName dict' $ do
      data_ks <- zipWithA (\tyCon (Tuple3 _ args ts) -> do
        kargs <- replicateM (length args) fresh
        let argDict = zip (map ProperName args) kargs
        bindLocalTypeVariables moduleName argDict $
          solveTypes true ts kargs tyCon) tyCons tys
      syn_ks <- zipWithA (\synVar (Tuple3 _ args ty) -> do
        kargs <- replicateM (length args) fresh
        let argDict = zip (map ProperName args) kargs
        bindLocalTypeVariables moduleName argDict $
          solveTypes false [ty] kargs synVar) synVars syns
      return (Tuple syn_ks data_ks)
  where
  tidyUp (Tuple (Tuple ks1 ks2) sub) = Tuple (map (starIfUnknown <<< (\x -> sub $? x)) ks1) (map (starIfUnknown <<< (\x -> sub $? x)) ks2)

-- |
-- Solve the set of kind constraints associated with the data constructors for a type constructor
--
solveTypes :: Boolean -> [Type] -> [Kind] -> Kind -> UnifyT Kind (Check) Kind
solveTypes isData ts kargs tyCon = traverse infer ts >>= \ks ->
  if isData
  then do
    tyCon =?= foldr FunKind Star kargs
    for_ ks $ \k -> k =?= Star
    return tyCon
  else do
    tyCon =?= foldr FunKind (head ks) kargs
    return tyCon

-- |
-- Default all unknown kinds to the Star kind of types
--
starIfUnknown :: Kind -> Kind
starIfUnknown (KUnknown _) = Star
starIfUnknown (Row k) = Row (starIfUnknown k)
starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
starIfUnknown k = k

-- |
-- Infer a kind for a type
--
infer :: Type -> UnifyT Kind Check Kind
infer ty = rethrow (\x -> mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <> x) $ infer' ty

infer' :: Type -> UnifyT Kind Check Kind
infer' (TypeVar v) = do
  Just moduleName <- (\(CheckState st) -> st.currentModule) <$> get
  UnifyT $ lift $ lookupTypeVariable unifyError moduleName (Qualified Nothing (ProperName v))
infer' c@(TypeConstructor v) = do
  Environment env <- liftCheck getEnv
  case M.lookup v env.types of
    Nothing -> UnifyT $ lift $ throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c))
    Just (Tuple kind _) -> return kind
infer' (TypeApp t1 t2) = do
  k0 <- fresh
  k1 <- infer t1
  k2 <- infer t2
  k1 =?= FunKind k2 k0
  return k0
infer' (ForAll ident ty _) = do
  k1 <- fresh
  Just moduleName <- (\(CheckState st) -> st.currentModule) <$> get
  k2 <- bindLocalTypeVariables moduleName [Tuple (ProperName ident) k1] $ infer ty
  k2 =?= Star
  return Star
infer' REmpty = do
  k <- fresh
  return $ Row k
infer' (RCons _ ty row) = do
  k1 <- infer ty
  k2 <- infer row
  k2 =?= Row k1
  return $ Row k1
infer' (ConstrainedType deps ty) = do
  for_ deps $ \(Tuple className tys) -> do
    _ <- infer $ foldl TypeApp (TypeConstructor className) tys
    return {}
  k <- infer ty
  k =?= Star
  return Star
infer' _ = error "Invalid argument to infer"

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


comment re: return of -1

comment re: return of -1

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


Updates for 0.7

Updates for 0.7

module Control.Monad.ST where

import Prelude

import Control.Monad.Eff (Eff(), runPure)

-- | The `ST` effect represents _local mutation_, i.e. mutation which does not "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to restrict the set of reference cells it is allowed to access.
-- |
-- | The `runST` function can be used to handle the `ST` effect.
foreign import data ST :: * -> !

-- | The type `STRef s a` represents a mutable reference holding a value of type `a`, which can be used with the `ST s` effect.
foreign import data STRef :: * -> * -> *

-- | Create a new mutable reference.
foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

-- | Read the current value of a mutable reference.
foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

-- | Modify the value of a mutable reference by applying a function to the current value.
foreign import modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

-- | Set the value of a mutable reference.
foreign import writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

-- | Run an `ST` computation.
-- |
-- | Note: the type of `runST` uses a rank-2 type to constrain the phantom type `s`, such that the computation must not leak any mutable references
-- | to the surrounding computation.
-- |
-- | It may cause problems to apply this function using the `$` operator. The recommended approach is to use parentheses instead.
foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

-- | A convenience function which combines `runST` with `runPure`, which can be used when the only required effect is `ST`.
-- |
-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
-- | is to use parentheses instead.
pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
pureST st = runPure (runST st)

module Control.Monad.ST where

import Control.Monad.Eff (Eff(), runPure)

-- | The `ST` effect represents _local mutation_, i.e. mutation which does not "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to restrict the set of reference cells it is allowed to access.
-- |
-- | The `runST` function can be used to handle the `ST` effect.
foreign import data ST :: * -> !

-- | The type `STRef s a` represents a mutable reference holding a value of type `a`, which can be used with the `ST s` effect.
foreign import data STRef :: * -> * -> *

-- | Create a new mutable reference.
foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

-- | Read the current value of a mutable reference.
foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

-- | Modify the value of a mutable reference by applying a function to the current value.
foreign import modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

-- | Set the value of a mutable reference.
foreign import writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

-- | Run an `ST` computation.
-- |
-- | Note: the type of `runST` uses a rank-2 type to constrain the phantom type `s`, such that the computation must not leak any mutable references
-- | to the surrounding computation.
-- |
-- | It may cause problems to apply this function using the `$` operator. The recommended approach is to use parentheses instead.
foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

-- | A convenience function which combines `runST` with `runPure`, which can be used when the only required effect is `ST`.
-- |
-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
-- | is to use parentheses instead.
pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
pureST st = runPure (runST st)


New error for handling failed session register

module Gonimo.Client.Types where

import Prelude
import Servant.PureScript.Affjax as Affjax
import Browser.LocalStorage (STORAGE)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff, class MonadAff)
import Control.Monad.Eff.Class (liftEff, class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (Error, EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (ExceptT(ExceptT))
import Control.Monad.Except.Trans (runExceptT, class MonadError, ExceptT)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO, class MonadIO)
import Control.Monad.Reader (ReaderT(ReaderT))
import Control.Monad.Reader.Class (local, ask, class MonadReader)
import Control.Monad.Reader.Trans (runReaderT, ReaderT)
import Data.Either (Either(Right, Left), either)
import Data.Generic (class Generic)
import Gonimo.WebAPI (SPParams_)
import Gonimo.WebAPI.Types (DeviceInfo)
import Network.HTTP.Affjax (AJAX)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (SPSettings_)
import Signal.Channel (CHANNEL)
import WebSocket (WEBSOCKET)

type Settings = SPSettings_ SPParams_

data GonimoError = AjaxError Affjax.AjaxError
                 | RegisterSessionFailed Affjax.AjaxError
                 | UnexpectedAction String

-- | Action type to use when errors should be handled by the parent component.
data ReportParent action = ReportError GonimoError
                         | Child action

-- | Action types that can be used for error reporting:
class ReportErrorAction action where
  reportError :: GonimoError -> action

instance reportErrorActionReportParent :: ReportErrorAction (ReportParent action) where
  reportError = ReportError

newtype Gonimo a = Gonimo (ReaderT Settings (ExceptT GonimoError IO) a)

-- We have runGonimo in Gonimo.Pux, so call it unwrap
unwrapGonimo :: forall a. Gonimo a -> (ReaderT Settings (ExceptT GonimoError IO) a)
unwrapGonimo (Gonimo m) = m

toIO :: forall action. ReportErrorAction action
        => Settings -> Gonimo action -> IO action
toIO settings m = map (either reportError id) <<< runExceptT <<< flip runReaderT settings <<< unwrapGonimo $ m

instance functorGonimo :: Functor (Gonimo) where
  map f (Gonimo m) = Gonimo $ map f m

instance applyGonimo :: Apply (Gonimo) where
  apply (Gonimo mf) (Gonimo ma) = Gonimo $ apply mf ma

instance applicativeGonimo :: Applicative (Gonimo) where
  pure = Gonimo <<< pure

instance bindGonimo :: Bind (Gonimo) where
  bind (Gonimo ma) mf = Gonimo $ bind ma (unwrapGonimo <<< mf)

instance monadGonimo :: Monad (Gonimo)

instance monadReaderSettingsGonimo :: MonadReader (SPSettings_ SPParams_) (Gonimo) where
  ask = Gonimo ask
  --local :: forall a. (r -> r) -> m a -> m a
  local f (Gonimo ma) = Gonimo (local f ma)

instance monadErrorErrorGonimo :: MonadError GonimoError (Gonimo) where
  throwError = Gonimo <<< throwError
  catchError (Gonimo ma) ef = Gonimo $ catchError ma (unwrapGonimo <<< ef)

instance monadErrorAjaxErrorGonimo :: MonadError AjaxError (Gonimo) where
  throwError = Gonimo <<< throwError <<< AjaxError
  catchError (Gonimo ma) ef = Gonimo $ catchError ma (unwrapGonimo <<< handleAjax)
    where
      handleAjax (AjaxError err) = ef err
      handleAjax err = throwError err

instance monadEffeffGonimo :: MonadEff eff Gonimo where
  liftEff = Gonimo <<< liftEff

instance monadAffeffGonimo :: MonadAff eff Gonimo where
  liftAff = Gonimo <<< liftAff

instance monadIOGonimo :: MonadIO Gonimo where
  liftIO m = Gonimo $ ReaderT $ \r -> ExceptT (map Right m)

-- | Info about an online baby station.
type BabyStationInfo =
  { deviceInfo :: DeviceInfo
  , babyName :: String
  }

module Gonimo.Client.Types where

import Prelude
import Servant.PureScript.Affjax as Affjax
import Browser.LocalStorage (STORAGE)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff, class MonadAff)
import Control.Monad.Eff.Class (liftEff, class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (Error, EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (ExceptT(ExceptT))
import Control.Monad.Except.Trans (runExceptT, class MonadError, ExceptT)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO, class MonadIO)
import Control.Monad.Reader (ReaderT(ReaderT))
import Control.Monad.Reader.Class (local, ask, class MonadReader)
import Control.Monad.Reader.Trans (runReaderT, ReaderT)
import Data.Either (Either(Right, Left), either)
import Data.Generic (class Generic)
import Gonimo.WebAPI (SPParams_)
import Gonimo.WebAPI.Types (DeviceInfo)
import Network.HTTP.Affjax (AJAX)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (SPSettings_)
import Signal.Channel (CHANNEL)
import WebSocket (WEBSOCKET)

type Settings = SPSettings_ SPParams_

data GonimoError = AjaxError Affjax.AjaxError
                 | UnexpectedAction String

-- | Action type to use when errors should be handled by the parent component.
data ReportParent action = ReportError GonimoError
                         | Child action

-- | Action types that can be used for error reporting:
class ReportErrorAction action where
  reportError :: GonimoError -> action

instance reportErrorActionReportParent :: ReportErrorAction (ReportParent action) where
  reportError = ReportError

newtype Gonimo a = Gonimo (ReaderT Settings (ExceptT GonimoError IO) a)

-- We have runGonimo in Gonimo.Pux, so call it unwrap
unwrapGonimo :: forall a. Gonimo a -> (ReaderT Settings (ExceptT GonimoError IO) a)
unwrapGonimo (Gonimo m) = m

toIO :: forall action. ReportErrorAction action
        => Settings -> Gonimo action -> IO action
toIO settings m = map (either reportError id) <<< runExceptT <<< flip runReaderT settings <<< unwrapGonimo $ m

instance functorGonimo :: Functor (Gonimo) where
  map f (Gonimo m) = Gonimo $ map f m

instance applyGonimo :: Apply (Gonimo) where
  apply (Gonimo mf) (Gonimo ma) = Gonimo $ apply mf ma

instance applicativeGonimo :: Applicative (Gonimo) where
  pure = Gonimo <<< pure

instance bindGonimo :: Bind (Gonimo) where
  bind (Gonimo ma) mf = Gonimo $ bind ma (unwrapGonimo <<< mf)

instance monadGonimo :: Monad (Gonimo)

instance monadReaderSettingsGonimo :: MonadReader (SPSettings_ SPParams_) (Gonimo) where
  ask = Gonimo ask
  --local :: forall a. (r -> r) -> m a -> m a
  local f (Gonimo ma) = Gonimo (local f ma)

instance monadErrorErrorGonimo :: MonadError GonimoError (Gonimo) where
  throwError = Gonimo <<< throwError
  catchError (Gonimo ma) ef = Gonimo $ catchError ma (unwrapGonimo <<< ef)

instance monadErrorAjaxErrorGonimo :: MonadError AjaxError (Gonimo) where
  throwError = Gonimo <<< throwError <<< AjaxError
  catchError (Gonimo ma) ef = Gonimo $ catchError ma (unwrapGonimo <<< handleAjax)
    where
      handleAjax (AjaxError err) = ef err
      handleAjax err = throwError err

instance monadEffeffGonimo :: MonadEff eff Gonimo where
  liftEff = Gonimo <<< liftEff

instance monadAffeffGonimo :: MonadAff eff Gonimo where
  liftAff = Gonimo <<< liftAff

instance monadIOGonimo :: MonadIO Gonimo where
  liftIO m = Gonimo $ ReaderT $ \r -> ExceptT (map Right m)

-- | Info about an online baby station.
type BabyStationInfo =
  { deviceInfo :: DeviceInfo
  , babyName :: String
  }


termsToQuery public

termsToQuery public

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/jonsterling/purescript-search.git/'


Another example for #185

Another example for #185

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


Support all units of purescript-quantities

module Insect (
  repl
  ) where

import Prelude hiding (degree)

import Control.Alt ((<|>))
import Control.Apply (lift2)

import Data.Quantity
import Data.Quantity.Math

import Data.Units
import Data.Units.SI
import Data.Units.SI.Derived
import Data.Units.SI.Accepted
import Data.Units.Imperial
import Data.Units.Time
import Data.Units.Bit

import Data.Array (fromFoldable)
import Data.Either (Either(..))
import Data.Maybe
import Data.String

import Global (readFloat, isFinite)

import Partial.Unsafe

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.Expr
import Text.Parsing.StringParser.String

pNumber :: Parser Number
pNumber = do
  intPart <- signAndDigits

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

  mExpPart <- optionMaybe (append <$> string "e" <*> signAndDigits)
  let expPart = fromMaybe "" mExpPart

  let num = readFloat (intPart <> fracPart <> expPart)

  if isFinite num
    then pure num
    else fail "Could not parse Number"

  where
    digits :: Parser String
    digits = do
      ds <- many1 anyDigit
      pure $ fromCharArray (fromFoldable ds)

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

pSIPrefix :: Parser (DerivedUnit → DerivedUnit)
pSIPrefix =
      (string "a" *> pure atto)
  <|> (string "f" *> pure femto)
  <|> (string "p" *> pure pico)
  <|> (string "n" *> pure nano)
  <|> (string "µ" *> pure micro)
  <|> (string "m" *> pure milli)
  <|> (string "c" *> pure centi)
  <|> (string "d" *> pure deci)
  <|> (string "h" *> pure hecto)
  <|> (string "k" *> pure kilo)
  <|> (string "M" *> pure mega)
  <|> (string "G" *> pure giga)
  <|> (string "T" *> pure tera)
  <|> (string "P" *> pure peta)
  <|> (string "E" *> pure exa)
  <|> pure id

pNormalUnit :: Parser DerivedUnit
pNormalUnit =
      (string "radians" *> pure radian)
  <|> (string "radian"  *> pure radian)
  <|> (string "rad"     *> pure radian)
  <|> (string "degrees" *> pure degree)
  <|> (string "degree"  *> pure degree)
  <|> (string "deg"     *> pure degree)
  <|> (string "hertz"   *> pure hertz)
  <|> (string "Hz"      *> pure hertz)
  <|> (string "N"       *> pure newton)
  <|> (string "J"       *> pure joule)
  <|> (string "W"       *> pure watt)
  <|> (string "bytes"   *> pure byte)
  <|> (string "byte"    *> pure byte)
  <|> (string "bits"    *> pure bit)
  <|> (string "bit"     *> pure bit)
  <|> (string "bps"     *> pure (bit ./ second))
  <|> (string "b"       *> pure byte)
  <|> (string "sec"     *> pure second)
  <|> (string "min"     *> pure minute)
  <|> (string "hours"   *> pure hour)
  <|> (string "hour"    *> pure hour)
  <|> (string "h"       *> pure hour)
  <|> (string "days"    *> pure day)
  <|> (string "day"     *> pure day)
  <|> (string "d"       *> pure day)
  <|> (string "weeks"   *> pure week)
  <|> (string "week"    *> pure week)
  <|> (string "m/h"     *> pure (meter ./ hour)) -- TODO: handle this differently
  <|> (string "m/s"     *> pure (meter ./ second)) -- TODO: handle this differently
  <|> (string "g"       *> pure gram)
  <|> (string "m"       *> pure meter)
  <|> (string "s"       *> pure second)
  <?> "Expected unit"

pImperialUnit :: Parser DerivedUnit
pImperialUnit =
      (string "miles"  *> pure mile)
  <|> (string "mile"   *> pure mile)
  -- <|> (string "mi"     *> pure mile)    TODO: this is incompatible with 'min'
  <|> (string "mph"    *> pure (mile ./ hour))
  <|> (string "inches" *> pure inch)
  <|> (string "inch"   *> pure inch)
  <|> (string "in"     *> pure inch)
  <|> (string "yards"  *> pure yard)
  <|> (string "yard"   *> pure yard)
  <|> (string "yd"     *> pure yard)
  <|> (string "feet"   *> pure foot)
  <|> (string "foot"   *> pure foot)
  <|> (string "ft"     *> pure foot)
  <|> (string "ounces" *> pure ounce)
  <|> (string "ounce"  *> pure ounce)
  <|> (string "oz"     *> pure ounce)
  <|> (string "pound"  *> pure pound)
  <|> (string "lb"     *> pure pound)

pUnitWithSIPrefix :: Parser DerivedUnit
pUnitWithSIPrefix = do
  p <- pSIPrefix
  u <- pNormalUnit
  pure $ p u

pUnit :: Parser DerivedUnit
pUnit = try pUnitWithSIPrefix
    <|> try pImperialUnit
    <|> try pNormalUnit
    <|> pure unity

pQuantity :: Parser Quantity
pQuantity = quantity <$> pNumber <*> pUnit

qS ea eb = do
  a <- ea
  b <- eb
  a ⊖ b

qA ea eb = do
  a <- ea
  b <- eb
  a ⊕ b

pExpr :: Parser (Either UnificationError Quantity)
pExpr = buildExprParser [ [ Infix (string "/" $> lift2 (⊘)) AssocRight ]
                        , [ Infix (string "*" $> lift2 (⊗)) AssocRight ]
                        , [ Infix (string "-" $> qS) AssocRight ]
                        , [ Infix (string "+" $> qA) AssocRight ]
                        ] (pure <$> pQuantity)

pInput :: Parser (Either UnificationError Quantity)
pInput = try conversion
  <|> (pExpr <* eof)
  where
    conversion = do
      expr <- pExpr
      string " to "
      target <- pUnit
      eof
      pure (expr >>= (flip convertTo) target)

repl :: String -> { out :: String, divClass :: String }
repl inp =
  case runParser pInput inp of
    Left parseErr -> { out: show parseErr, divClass: "error" }
    Right res ->
      case res of
        Left unificationError -> { out: errorMessage unificationError, divClass: "error" }
        Right val -> { out: prettyPrint val, divClass: "value" }

module Insect (
  repl
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply (lift2)

import Data.Quantity
import Data.Quantity.Math

import Data.Units
import Data.Units.SI
import Data.Units.SI.Derived
import Data.Units.SI.Accepted
import Data.Units.Imperial
import Data.Units.Time
import Data.Units.Bit

import Data.Array (fromFoldable)
import Data.Either (Either(..))
import Data.Maybe
import Data.String

import Global (readFloat, isFinite)

import Partial.Unsafe

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.Expr
import Text.Parsing.StringParser.String

pNumber :: Parser Number
pNumber = do
  intPart <- signAndDigits

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

  mExpPart <- optionMaybe (append <$> string "e" <*> signAndDigits)
  let expPart = fromMaybe "" mExpPart

  let num = readFloat (intPart <> fracPart <> expPart)

  if isFinite num
    then pure num
    else fail "Could not parse Number"

  where
    digits :: Parser String
    digits = do
      ds <- many1 anyDigit
      pure $ fromCharArray (fromFoldable ds)

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

pSIPrefix :: Parser (DerivedUnit → DerivedUnit)
pSIPrefix =
      (string "a" *> pure atto)
  <|> (string "f" *> pure femto)
  <|> (string "p" *> pure pico)
  <|> (string "n" *> pure nano)
  <|> (string "µ" *> pure micro)
  <|> (string "m" *> pure milli)
  <|> (string "c" *> pure centi)
  <|> (string "d" *> pure deci)
  <|> (string "h" *> pure hecto)
  <|> (string "k" *> pure kilo)
  <|> (string "M" *> pure mega)
  <|> (string "G" *> pure giga)
  <|> (string "T" *> pure tera)
  <|> (string "P" *> pure peta)
  <|> (string "E" *> pure exa)
  <|> pure id

pNormalUnit :: Parser DerivedUnit
pNormalUnit =
      (string "sec"   *> pure second)
  <|> (string "min"   *> pure minute)
  <|> (string "hours" *> pure hour)
  <|> (string "hour"  *> pure hour)
  <|> (string "h"     *> pure hour)
  <|> (string "days"  *> pure day)
  <|> (string "day"   *> pure day)
  <|> (string "d"     *> pure day)
  <|> (string "weeks" *> pure week)
  <|> (string "week"  *> pure week)
  <|> (string "m/h"   *> pure (meter ./ hour)) -- TODO
  <|> (string "m/s"   *> pure (meter ./ second)) -- TODO
  <|> (string "g"     *> pure gram)
  <|> (string "m"     *> pure meter)
  <|> (string "s"     *> pure second)
  <?> "Expected unit"

pImperialUnit :: Parser DerivedUnit
pImperialUnit =
      (string "miles" *> pure mile)
  <|> (string "mile"  *> pure mile)
  -- <|> (string "mi"    *> pure mile)    TODO: this is incompatibel with 'min'
  <|> (string "mph"   *> pure (mile ./ hour))
  <|> (string "in"    *> pure inch)
  <|> (string "ft"    *> pure foot)

pUnitWithSIPrefix :: Parser DerivedUnit
pUnitWithSIPrefix = do
  p <- pSIPrefix
  u <- pNormalUnit
  pure $ p u

pUnit :: Parser DerivedUnit
pUnit = try pUnitWithSIPrefix
    <|> try pImperialUnit
    <|> try pNormalUnit
    <|> pure unity

pQuantity :: Parser Quantity
pQuantity = quantity <$> pNumber <*> pUnit

qS ea eb = do
  a <- ea
  b <- eb
  a ⊖ b

qA ea eb = do
  a <- ea
  b <- eb
  a ⊕ b

pExpr :: Parser (Either UnificationError Quantity)
pExpr = buildExprParser [ [ Infix (string "/" $> lift2 (⊘)) AssocRight ]
                        , [ Infix (string "*" $> lift2 (⊗)) AssocRight ]
                        , [ Infix (string "-" $> qS) AssocRight ]
                        , [ Infix (string "+" $> qA) AssocRight ]
                        ] (pure <$> pQuantity)

pInput :: Parser (Either UnificationError Quantity)
pInput = try conversion
  <|> (pExpr <* eof)
  where
    conversion = do
      expr <- pExpr
      string " to "
      target <- pUnit
      eof
      pure (expr >>= (flip convertTo) target)

repl :: String -> { out :: String, divClass :: String }
repl inp =
  case runParser pInput inp of
    Left parseErr -> { out: show parseErr, divClass: "error" }
    Right res ->
      case res of
        Left unificationError -> { out: errorMessage unificationError, divClass: "error" }
        Right val -> { out: prettyPrint val, divClass: "value" }


Adding placeholder for `CardIterator`

Adding placeholder for `CardIterator`

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


Prepare module for IO code

Prepare module for IO code

module Data.TimeSeries.IO where

-- | Load TimeSeries from CSV at given URL
-- fromCsv :: String -> TimeSeries

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


Add test for Prelude's unsafeCompare FFI call

module Main where

import Control.Monad.Eff
import Debug.Trace

foreign import data Assert :: !

foreign import assert
  "function assert(x) {\
  \  return function () {\
  \    if (!x) throw new Error('assertion failed');\
  \    return {};\
  \  };\
  \};" :: forall e. Boolean -> Eff (assert :: Assert | e) Unit

main = do
  assert (1 < 2)
  assert (2 == 2)
  assert (3 > 1)
  assert ("a" < "b")
  assert ("a" == "a")
  assert ("z" > "a")
  trace "Done!"

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


fix purescript-rx breakage.

fix purescript-rx breakage.

Monadic bind was reassigned to flatMap when we needed flatMapLatest

module Openspace.Ui.Stream where

import Control.Monad.Eff
import Control.Monad.ST
import DOM
import Data.Either
import Data.Foreign
import Openspace.Engine
import Openspace.Network.Socket
import Openspace.Types
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Ui.Render
import Prelude
import Rx.Observable

netStream :: forall eff. Socket -> Eff( net :: Net | eff ) (Observable Action)
netStream socket = do
  onReceive <- socketObserver socket
  return $ actionFromForeign parseAction id <$> (parseMessage <$> onReceive)

dragStream :: forall eff. Eff( dom :: DOM| eff) (Observable Action)
dragStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left err -> UnassignTopic
                     ) <$> lookup "dragOverSlot"

      dragOverTrash = const DeleteTopic <$> lookup "dragOverTrash"

      -- HTML 5 fires dragLeave before dragEnd occurs
      -- TODO: Find a cleaner solution
      dragLeave = delay 30 $ const UnassignTopic
                  <$> lookup "dragLeaveSlot" `merge` lookup "dragLeaveTrash"

      dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

      dragStart = parseTopic <<< getDetail
                  <$> lookup "dragStartTopic" `merge` lookup "dragStartGridTopic"

      {-
         rebindable "bind" would make this a lot easier
      -}
      dragTopic = dragStart `flatMapLatest`
           (\(Right t) -> dragOver `flatMapLatest`
             (\action -> lookup "dragEndTopic" `merge` lookup "dragEndGridTopic" `flatMapLatest`
               (\_ -> return $ action t)))
  return dragTopic

uiStream :: forall eff. Eff( dom :: DOM | eff ) (Observable Action)
uiStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      addTopic    = (actionFromForeign parseTopic AddTopic) <<< getDetail
                    <$> lookup "addTopic"
      addRoom     = (actionFromForeign parseRoom AddRoom) <<< getDetail
                    <$> lookup "addRoom"
      deleteRoom  = (actionFromForeign parseRoom DeleteRoom) <<< getDetail
                    <$> lookup "deleteRoom"
      addBlock    = (actionFromForeign parseBlock AddBlock) <<< getDetail
                    <$> lookup "addBlock"
      deleteBlock = (actionFromForeign parseBlock DeleteBlock) <<< getDetail
                    <$> lookup "deleteBlock"
      changeGrid = addRoom `merge` deleteRoom `merge` addBlock `merge` deleteBlock
  dragTopic <- dragStream
  return $ addTopic `merge` dragTopic `merge` changeGrid

main = do
  socketUrl <- getSocketUrl
  let sockEmitter = getSocket ("ws://" ++ socketUrl)
  -- until Websocket support is given by the server
  -- let sockEmitter = EmptySocket
  -- Initial State
  appSt <- newSTRef emptyState
  -- Initial Render
  renderMenu (show <$> topicTypes)
  readSTRef appSt >>= renderApp

  --Request Initial State
  emitRefresh sockEmitter

  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  subscribe ui (\a -> emitAction sockEmitter (serialize a))
  -- Evaluate Action Observables
  let actions = net --ui `merge` net
  subscribe actions (\a -> modifySTRef appSt (evalAction a) >>= renderApp)

module Openspace.Ui.Stream where

import Control.Monad.Eff
import Control.Monad.ST
import DOM
import Data.Either
import Data.Foreign
import Openspace.Engine
import Openspace.Network.Socket
import Openspace.Types
import Openspace.Ui.Emitter
import Openspace.Ui.Parser
import Openspace.Ui.Render
import Prelude
import Rx.Observable

netStream :: forall eff. Socket -> Eff( net :: Net | eff ) (Observable Action)
netStream socket = do
  onReceive <- socketObserver socket
  return $ actionFromForeign parseAction id <$> (parseMessage <$> onReceive)

dragStream :: forall eff. Eff( dom :: DOM| eff) (Observable Action)
dragStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      dragOverSlot = (\e -> case parseSlot (getDetail e) of
                         Right s -> AssignTopic s
                         Left err -> UnassignTopic
                     ) <$> lookup "dragOverSlot"

      dragOverTrash = const DeleteTopic <$> lookup "dragOverTrash"

      -- HTML 5 fires dragLeave before dragEnd occurs
      -- TODO: Find a cleaner solution
      dragLeave = delay 30 $ const UnassignTopic
                  <$> lookup "dragLeaveSlot" `merge` lookup "dragLeaveTrash"

      dragOver = dragLeave `merge` dragOverSlot `merge` dragOverTrash

      dragStart = parseTopic <<< getDetail
                  <$> lookup "dragStartTopic" `merge` lookup "dragStartGridTopic"

      dragTopic = do Right t <- dragStart
                     action <- dragOver
                     lookup "dragEndTopic" `merge` lookup "dragEndGridTopic"
                     return $ action t
  return dragTopic

uiStream :: forall eff. Eff( dom :: DOM | eff ) (Observable Action)
uiStream = do
  emitters <- getEmitters
  let lookup = emitterLookup emitters
      addTopic    = (actionFromForeign parseTopic AddTopic) <<< getDetail
                    <$> lookup "addTopic"
      addRoom     = (actionFromForeign parseRoom AddRoom) <<< getDetail
                    <$> lookup "addRoom"
      deleteRoom  = (actionFromForeign parseRoom DeleteRoom) <<< getDetail
                    <$> lookup "deleteRoom"
      addBlock    = (actionFromForeign parseBlock AddBlock) <<< getDetail
                    <$> lookup "addBlock"
      deleteBlock = (actionFromForeign parseBlock DeleteBlock) <<< getDetail
                    <$> lookup "deleteBlock"
      changeGrid = addRoom `merge` deleteRoom `merge` addBlock `merge` deleteBlock
  dragTopic <- dragStream
  return $ addTopic `merge` dragTopic `merge` changeGrid

main = do
  socketUrl <- getSocketUrl
  let sockEmitter = getSocket ("ws://" ++ "frost.kritzcreek.me/socket/ba27265e-4dad-4bc7-bce0-6d2435da0496" ) -- ++ socketUrl)
  -- until Websocket support is given by the server
  -- let sockEmitter = EmptySocket
  -- Initial State
  appSt <- newSTRef emptyState
  -- Initial Render
  renderMenu (show <$> topicTypes)
  readSTRef appSt >>= renderApp

  --Request Initial State
  emitRefresh sockEmitter

  -- Observable Action
  ui  <- uiStream
  net <- netStream sockEmitter
  -- Broadcast the UI Observable
  subscribe ui (\a -> emitAction sockEmitter (serialize a))
  -- Evaluate Action Observables
  let actions = net --ui `merge` net
  subscribe actions (\a -> modifySTRef appSt (evalAction a) >>= renderApp)


Added Central.purs

Added Central.purs

module Gonimo.UI.Loaded.Central where

import Prelude
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Invite as InviteC
import Data.Array (fromFoldable)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(Tuple))
import Gonimo.UI.Loaded.Types (CentralReq(ReqCentralHome, ReqCentralInvite), mkProps, Central(CentralHome, CentralAccept, CentralInvite), State)
import Gonimo.Util (class UserShow)

getCentrals :: State -> Array (Tuple Boolean CentralReq)
getCentrals state =
  let
    props = mkProps state
    currentCentral = centralToRequest state.central
    reqs = [ ReqCentralHome, ReqCentralInvite ]
    toEntry req = Tuple (Just req == currentCentral) req
  in
   map toEntry reqs

centralToRequest :: Central -> Maybe CentralReq
centralToRequest c = case c of
  CentralInvite _ -> Just ReqCentralInvite
  CentralHome     -> Just ReqCentralHome
  CentralAccept _ -> Nothing

error: pathspec 'src/Gonimo/UI/Loaded/Central.purs' did not match any file(s) known to git


Add functions for parsing TrackSource/Sink configs

module Genetics.Browser.Config.Events where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Except (throwError)
import Data.Argonaut (Json, _Object, (.?))
import Data.Either (Either)
import Data.Foreign (F, Foreign, readString, unsafeReadTagged)
import Data.Foreign.Index ((!))
import Data.Lens ((^?))
import Data.Maybe (Maybe(..))
import Genetics.Browser.Biodalliance.Types (Biodalliance)
import Genetics.Browser.Cytoscape.Types (Cytoscape)
import Genetics.Browser.Events.TrackSink (SinkConfig)
import Genetics.Browser.Events.TrackSource (SourceConfig)
import Unsafe.Coerce (unsafeCoerce)

parseTrackSourceConfig :: Foreign -> F SourceConfig
parseTrackSourceConfig for = do
  eventName <- readString =<< for ! "eventName"
  eventTemplate <- for ! "eventTemplate"
  rawTemplate <- for ! "rawTemplate"
  pure $ { eventName
         , eventTemplate: unsafeCoerce eventTemplate
         , rawTemplate: unsafeCoerce rawTemplate
         }

-- this is so unsafe
parseTrackSinkConfig :: ∀ a. Foreign -> F (SinkConfig a)
parseTrackSinkConfig for = do
  eventName <- readString =<< for ! "eventName"
  eventFun <- for ! "eventTemplate" >>= unsafeReadTagged "Function"
  pure $ { eventName
         , eventFun: unsafeCoerce eventFun
         }

parseBDTrackSinkConfig :: Foreign
                       -> F (SinkConfig (Biodalliance -> Eff _ Unit))
parseBDTrackSinkConfig f = unsafeCoerce (parseTrackSinkConfig f)

parseCyGraphSinkConfig :: Foreign
                       -> F (SinkConfig (Cytoscape -> Eff _ Unit))
parseCyGraphSinkConfig f = unsafeCoerce (parseTrackSinkConfig f)

error: pathspec 'src/Genetics/Browser/Config/Events.purs' did not match any file(s) known to git


5.9.1

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


#445 Spinner for loading settings

#445 Spinner for loading settings

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 Request.Helper.Headers

add Request.Helper.Headers

module Request.Helper.Headers
  ( headers
  , headersWithoutToken
  ) where

import Data.Show (show)
import Data.StrMap (StrMap, fromFoldable)
import Data.Tuple (Tuple(..))
import Prelude (($), (<>))

headers :: String -> StrMap String
headers token =
  fromFoldable [ Tuple "Content-Type" "application/json"
               , Tuple "User-Agent" "rally-cli"
               , Tuple "Authorization" $ "Token token=" <> show token
               ]

headersWithoutToken :: StrMap String
headersWithoutToken =
  fromFoldable [ Tuple "Content-Type" "application/json"
               , Tuple "User-Agent" "rally-cli"
               ]

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


Works now: Hours of task grouped to same line in output.

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/0dB/cats-utils.git/'


Factor out setTimeout, fix type error

Factor out setTimeout, fix type error

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/ruicc/purescript-lifegame.git/'


Very basic test suite

Very basic test suite

module Main where

import Console (log)
import Control.Monad.Eff

foreign import throwError
  """
  function throwError(msg) {
    throw new Error(msg)
  }
  """ :: forall e. String -> Eff e Unit

check :: forall e a. (Show a, Ord a) => Ordering -> a -> a -> Eff e Unit
check expected a b =
  let actual = compare a b
  in if actual == expected
    then return unit
    else throwError (show a <> " `compare` " <> show b <> ": " <>
                      "expected " <> show expected <> ", got " <> show actual)

main = do
  check EQ [] ([] :: Array Number)
  check LT [] [0]
  check EQ [1,2,3] [1,2,3]
  check LT [1,1,3] [1,2,3]

  log "All good!"

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


Client changed

Client changed

-- File auto generated by purescript-bridge! --
module Gonimo.Server.DbEntities where

import Data.Maybe (Maybe)
import Gonimo.Server.Types (AuthToken, InvitationDelivery)
import Gonimo.Types (Date, Family, Key, Secret)
import Prim (String)

import Data.Generic (class Generic)

data Account =
    Account {
      accountCreated :: Date
    }

derive instance genericAccount :: Generic Account

data Client =
    Client {
      clientName :: String
    , clientAuthToken :: AuthToken
    , clientAccountId :: Key Account
    , clientLastAccessed :: Date
    , clientUserAgent :: String
    }

derive instance genericClient :: Generic Client

data Invitation =
    Invitation {
      invitationSecret :: Secret
    , invitationFamilyId :: Key Family
    , invitationCreated :: Date
    , invitationDelivery :: InvitationDelivery
    , invitationSenderId :: Key Client
    , invitationReceiverId :: Maybe (Key Account)
    }

derive instance genericInvitation :: Generic Invitation

-- File auto generated by purescript-bridge! --
module Gonimo.Server.DbEntities where

import Data.Maybe (Maybe)
import Gonimo.Server.Types (AuthToken, InvitationDelivery)
import Gonimo.Types (Date, Family, Key, Secret)
import Prim (String)

import Data.Generic (class Generic)

data Account =
    Account {
      accountCreated :: Date
    }

derive instance genericAccount :: Generic Account

data Client =
    Client {
      clientName :: String
    , clientAuthToken :: AuthToken
    , clientAccountId :: Key Account
    , clientLastAccessed :: Date
    }

derive instance genericClient :: Generic Client

data Invitation =
    Invitation {
      invitationSecret :: Secret
    , invitationFamilyId :: Key Family
    , invitationCreated :: Date
    , invitationDelivery :: InvitationDelivery
    , invitationSenderId :: Key Client
    , invitationReceiverId :: Maybe (Key Account)
    }

derive instance genericInvitation :: Generic Invitation


Add Language.PureScript.Pretty.Kinds

Add Language.PureScript.Pretty.Kinds

module Language.PureScript.Pretty.Kinds (prettyPrintKind) where

import Data.Maybe
import Data.Tuple

import Control.Arrow
import Text.Pretty.PatternArrows

import Language.PureScript.Errors (theImpossibleHappened)
import Language.PureScript.Kinds
import Language.PureScript.Pretty.Common

typeLiterals :: Pattern Unit Kind String
typeLiterals = mkPattern match
  where
  match Star = Just "*"
  match Bang = Just "!"
  match (KUnknown u) = Just $ "u" ++ show u
  match _ = Nothing

matchRow :: Pattern Unit Kind (Tuple Unit Kind)
matchRow = mkPattern match
  where
  match (Row k) = Just (Tuple unit k)
  match _ = Nothing

funKind :: Pattern Unit Kind (Tuple Kind Kind)
funKind = mkPattern match
  where
  match (FunKind arg ret) = Just (Tuple arg ret)
  match _ = Nothing

-- |
-- Generate a pretty-printed string representing a Kind
--
prettyPrintKind :: Kind -> String
prettyPrintKind k = case pattern matchKind unit k of
    Just x -> x
    Nothing -> theImpossibleHappened "Incomplete pattern"
  where
  matchKind :: Pattern Unit Kind String
  matchKind = fix $ \p -> buildPrettyPrinter operators (typeLiterals <+> (parens <$> p))
  operators :: OperatorTable Unit Kind String
  operators =
    OperatorTable [ [ Operator (wrap matchRow $ \_ k -> "# " ++ k) ]
                  , [ Operator (assocR funKind $ \arg ret -> arg ++ " -> " ++ ret) ] ]

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


Simplify types

Simplify types

module Network.HTTP.Client where

import Data.Maybe
import Data.Function

import Control.Monad.Eff
import Control.Monad.Eff.Ref

import Control.Monad.Trans
import Control.Monad.Cont.Trans
import Control.Monad.Cont.Extras

foreign import data HTTP :: !

newtype Request = Request
  { host :: String
  , path :: String
  }

newtype Chunk = Chunk String

instance showChunk :: Show Chunk where
  show (Chunk s) = "Chunk " ++ show s

newtype Response = Response [Chunk]

instance showResponse :: Show Response where
  show (Response cs) = "Response " ++ show cs

runChunk :: Chunk -> String
runChunk (Chunk s) = s

type WithHTTP eff = Eff (http :: HTTP | eff)

foreign import getImpl
  "function getImpl(opts, more, done) {\
  \  return function() {\
  \    require('http').request(opts, function(res) {\
  \      res.setEncoding('utf8');\
  \      res.on('data', function (s) {\
  \        more(s)();\
  \      });\
  \      res.on('end', function () {\
  \        done();\
  \      });\
  \    }).end();\
  \  };\
  \}" :: forall eff. Fn3 Request
                         (Chunk -> WithHTTP eff Unit)
                         (WithHTTP eff Unit)
                         (WithHTTP eff Unit)

getChunk :: forall eff. Request ->
                        (Maybe Chunk -> WithHTTP eff Unit) ->
                        WithHTTP eff Unit
getChunk req k = runFn3 getImpl req (k <<< Just) (k Nothing)

getCont :: forall eff. Request -> ContT Unit (WithHTTP eff) (Maybe Chunk)
getCont req = ContT $ getChunk req

getAll :: forall eff. Request -> ContT Unit (WithHTTP (ref :: Ref | eff)) Response
getAll req = Response <$> collect (getCont req)

module Network.HTTP.Client where

import Data.Maybe
import Data.Function

import Control.Monad.Eff
import Control.Monad.Eff.Ref

import Control.Monad.Trans
import Control.Monad.Cont.Trans
import Control.Monad.Cont.Extras

foreign import data HTTP :: !

newtype Request = Request
  { host :: String
  , path :: String
  }

newtype Chunk = Chunk String

instance showChunk :: Show Chunk where
  show (Chunk s) = "Chunk " ++ show s

newtype Response = Response [Chunk]

instance showResponse :: Show Response where
  show (Response cs) = "Response " ++ show cs

runChunk :: Chunk -> String
runChunk (Chunk s) = s

type WithHTTP eff = Eff (http :: HTTP | eff)

foreign import getImpl
  "function getImpl(opts, more, done) {\
  \  return function() {\
  \    require('http').request(opts, function(res) {\
  \      res.setEncoding('utf8');\
  \      res.on('data', function (s) {\
  \        more(s)();\
  \      });\
  \      res.on('end', function () {\
  \        done();\
  \      });\
  \    }).end();\
  \  };\
  \}" :: forall eff a b. Fn3 Request
                             (Chunk -> WithHTTP eff a)
                             (WithHTTP eff b)
                             (WithHTTP eff Unit)

getChunk :: forall eff a. Request ->
                          (Maybe Chunk -> WithHTTP eff a) ->
                          WithHTTP eff Unit
getChunk req k = runFn3 getImpl req (k <<< Just) (k Nothing)

getCont :: forall eff. Request -> ContT Unit (WithHTTP eff) (Maybe Chunk)
getCont req = ContT $ getChunk req

getAll :: forall eff. Request -> ContT Unit (WithHTTP (ref :: Ref | eff)) Response
getAll req = Response <$> collect (getCont req)


Add type & function for creating BD track configs

module Genetics.Browser.Config.Track
       where

import Prelude
import Data.Foreign (Foreign, toForeign)

newtype BDTrackConfig = BDTrackConfig Foreign

makeBDTrack :: ∀ r. { name :: String, renderer :: String | r } -> BDTrackConfig
makeBDTrack = (BDTrackConfig <<< toForeign)

error: pathspec 'src/Genetics/Browser/Config/Track.purs' did not match any file(s) known to git


Add Language.PureScript.Pretty.Types

Add Language.PureScript.Pretty.Types

module Language.PureScript.Pretty.Types
  ( prettyPrintType
  , prettyPrintTypeAtom
  , prettyPrintRow
  ) where

import Control.Arrow ((<+>))
import Data.Array (map)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.String (joinWith)
import Data.Tuple
import Text.Pretty.PatternArrows

import Language.PureScript.Environment
import Language.PureScript.Pretty.Common
import Language.PureScript.Types

typeLiterals :: Unit -> Pattern Unit Type String
typeLiterals _ = mkPattern match
  where
  match (TypeVar var) = Just var
  match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
  match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
  match (TypeConstructor ctor) = Just $ show ctor
  match (TUnknown u) = Just $ "u" ++ show u
  match (Skolem name s _) = Just $ name ++ show s
  match (ConstrainedType deps ty) = Just $ "(" ++ joinWith ", " (map (\(Tuple pn ty') -> show pn ++ " " ++ joinWith " " (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
  match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ joinWith "," (map prettyPrintTypeAtom args) ++ ">"
  match REmpty = Just "()"
  match row@(RCons _ _ _) = Just $ "(" ++ prettyPrintRow row ++ ")"
  match _ = Nothing

typeApp :: Pattern Unit Type (Tuple Type Type)
typeApp = mkPattern match
  where
  match (TypeApp f x) = Just (Tuple f x)
  match _ = Nothing

appliedFunction :: Pattern Unit Type (Tuple Type Type)
appliedFunction = mkPattern match
  where
  match (PrettyPrintFunction arg ret) = Just (Tuple arg ret)
  match _ = Nothing

insertPlaceholders :: Type -> Type
insertPlaceholders = everywhereOnTypesTopDown convertForAlls <<< everywhereOnTypes convert
  where
  convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
  convert (TypeApp a el) | a == tyArray = PrettyPrintArray el
  convert (TypeApp o r) | o == tyObject = PrettyPrintObject r
  convert other = other
  convertForAlls (ForAll ident ty _) = go [ident] ty
    where
    go idents (ForAll ident' ty' _) = go (ident' : idents) ty'
    go idents other = PrettyPrintForAll idents other
  convertForAlls other = other

matchTypeAtom :: Unit -> Pattern Unit Type String
matchTypeAtom _ = typeLiterals unit <+> (parens <$> matchType unit)

matchType :: Unit -> Pattern Unit Type String
matchType _ = buildPrettyPrinter operators (matchTypeAtom unit)
  where
  operators :: OperatorTable Unit Type String
  operators =
    OperatorTable [ [ Operator (assocL typeApp $ \f x -> f ++ " " ++ x) ]
                  , [ Operator (assocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret) ]
                  , [ Operator (wrap forall_ $ \idents ty -> "forall " ++ joinWith " " idents ++ ". " ++ ty) ]
                  ]

forall_ :: Pattern Unit Type (Tuple [String] Type)
forall_ = mkPattern match
  where
  match (PrettyPrintForAll idents ty) = Just (Tuple idents ty)
  match _ = Nothing

-- |
-- Generate a pretty-printed string representing a Type, as it should appear inside parentheses
--
prettyPrintTypeAtom :: Type -> String
prettyPrintTypeAtom p = runPretty (pattern (matchTypeAtom unit) unit <<< insertPlaceholders) p

-- |
-- Generate a pretty-printed string representing a Type
--
prettyPrintType :: Type -> String
prettyPrintType p = runPretty (pattern (matchType unit) unit <<< insertPlaceholders) p

-- |
-- Generate a pretty-printed string representing a Row
--
prettyPrintRow :: Type -> String
prettyPrintRow t = (\(Tuple tys rest) -> joinWith ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) $ toList [] t
  where
  nameAndTypeToPs :: String -> Type -> String
  nameAndTypeToPs name ty = prettyPrintObjectKey name ++ " :: " ++ prettyPrintType ty
  tailToPs :: Type -> String
  tailToPs REmpty = ""
  tailToPs other = " | " ++ prettyPrintType other
  toList :: [Tuple String Type] -> Type -> (Tuple [Tuple String Type] Type)
  toList tys (RCons name ty row) = toList ((Tuple name ty):tys) row
  toList tys r = (Tuple tys r)

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


Performance improvements for 0.7.6

Performance improvements for 0.7.6

-- | This module defines a type of maps as balanced 2-3 trees, based on
-- | <http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf>

module Data.Map
  ( Map()
  , showTree
  , empty
  , isEmpty
  , singleton
  , checkValid
  , insert
  , lookup
  , fromFoldable
  , fromFoldableWith
  , toList
  , fromList
  , fromListWith
  , delete
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  ) where

import Prelude

import Data.Foldable (foldl, foldMap, foldr, Foldable)
import Data.List (List(..), length, nub)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Maybe.Unsafe (unsafeThrow)
import Data.Monoid (Monoid)
import Data.Traversable (traverse, Traversable)
import Data.Tuple (Tuple(..), uncurry)

-- | `Map k v` represents maps from keys of type `k` to values of type `v`.
data Map k v
  = Leaf
  | Two (Map k v) k v (Map k v)
  | Three (Map k v) k v (Map k v) k v (Map k v)

instance eqMap :: (Eq k, Eq v) => Eq (Map k v) where
  eq m1 m2 = toList m1 == toList m2

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "fromList " ++ show (toList m)

instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where
  compare m1 m2 = compare (toList m1) (toList m2)

instance semigroupMap :: (Ord k) => Semigroup (Map k v) where
  append = union

instance monoidMap :: (Ord k) => Monoid (Map k v) where
  mempty = empty

instance functorMap :: Functor (Map k) where
  map _ Leaf = Leaf
  map f (Two left k v right) = Two (map f left) k (f v) (map f right)
  map f (Three left k1 v1 mid k2 v2 right) = Three (map f left) k1 (f v1) (map f mid) k2 (f v2) (map f right)

instance foldableMap :: Foldable (Map k) where
  foldl   f z m = foldl   f z (values m)
  foldr   f z m = foldr   f z (values m)
  foldMap f   m = foldMap f   (values m)

instance traversableMap :: (Ord k) => Traversable (Map k) where
  traverse f ms = foldr (\x acc -> union <$> x <*> acc) (pure empty) (((<$>) (uncurry singleton)) <$> (traverse f <$> toList ms))
  sequence = traverse id

-- | Render a `Map` as a `String`
showTree :: forall k v. (Show k, Show v) => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
  "Two (" ++ showTree left ++
  ") (" ++ show k ++
  ") (" ++ show v ++
  ") (" ++ showTree right ++ ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" ++ showTree left ++
  ") (" ++ show k1 ++
  ") (" ++ show v1 ++
  ") (" ++ showTree mid ++
  ") (" ++ show k2 ++
  ") (" ++ show v2 ++
  ") (" ++ showTree right ++ ")"

-- | An empty map
empty :: forall k v. Map k v
empty = Leaf

-- | Test if a map is empty
isEmpty :: forall k v. Map k v -> Boolean
isEmpty Leaf = true
isEmpty _ = false

-- | Create a map with one key/value pair
singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

-- | Check whether the underlying tree satisfies the 2-3 invariant
-- |
-- | This function is provided for internal use.
checkValid :: forall k v. Map k v -> Boolean
checkValid tree = length (nub (allHeights tree)) == one
  where
  allHeights :: Map k v -> List Int
  allHeights Leaf = pure zero
  allHeights (Two left _ _ right) = map (\n -> n + one) (allHeights left ++ allHeights right)
  allHeights (Three left _ _ mid _ _ right) = map (\n -> n + one) (allHeights left ++ allHeights mid ++ allHeights right)

-- | Lookup a value for the specified key
lookup :: forall k v. (Ord k) => k -> Map k v -> Maybe v
lookup k tree =
  let comp :: k -> k -> Ordering
      comp = compare
  in case tree of
    Leaf -> Nothing
    Two left k1 v right ->
      case comp k k1 of
        EQ -> Just v
        LT -> lookup k left
        _  -> lookup k right
    Three left k1 v1 mid k2 v2 right ->
      case comp k k1 of
        EQ -> Just v1
        c1 ->
          case comp k k2 of
            EQ -> Just v2
            c2 ->
              case c1 of
                LT -> lookup k left
                _  ->
                  case c2 of
                    GT -> lookup k right
                    _  -> lookup k mid

-- | Test if a key is a member of a map
member :: forall k v. (Ord k) => k -> Map k v -> Boolean
member k m = isJust (k `lookup` m)

data TreeContext k v
  = TwoLeft k v (Map k v)
  | TwoRight (Map k v) k v
  | ThreeLeft k v (Map k v) k v (Map k v)
  | ThreeMiddle (Map k v) k v k v (Map k v)
  | ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. (Ord k) => List (TreeContext k v) -> Map k v -> Map k v
fromZipper Nil tree = tree
fromZipper (Cons x ctx) tree =
  case x of
    TwoLeft k1 v1 right -> fromZipper ctx (Two tree k1 v1 right)
    TwoRight left k1 v1 -> fromZipper ctx (Two left k1 v1 tree)
    ThreeLeft k1 v1 mid k2 v2 right -> fromZipper ctx (Three tree k1 v1 mid k2 v2 right)
    ThreeMiddle left k1 v1 k2 v2 right -> fromZipper ctx (Three left k1 v1 tree k2 v2 right)
    ThreeRight left k1 v1 mid k2 v2 -> fromZipper ctx (Three left k1 v1 mid k2 v2 tree)

data KickUp k v = KickUp (Map k v) k v (Map k v)

-- | Insert a key/value pair into a map
insert :: forall k v. (Ord k) => k -> v -> Map k v -> Map k v
insert = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> k -> v -> Map k v -> Map k v
  down ctx k v Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx k v (Two left k1 v1 right) =
    case comp k k1 of
      EQ -> fromZipper ctx (Two left k v right)
      LT -> down (Cons (TwoLeft k1 v1 right) ctx) k v left
      _  -> down (Cons (TwoRight left k1 v1) ctx) k v right
  down ctx k v (Three left k1 v1 mid k2 v2 right) =
    case comp k k1 of
      EQ -> fromZipper ctx (Three left k v mid k2 v2 right)
      c1 ->
        case comp k k2 of
          EQ -> fromZipper ctx (Three left k1 v1 mid k v right)
          c2 ->
            case c1 of
              LT -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k v left
              GT ->
                case c2 of
                  LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k v mid
                  _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k v right
              _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k v right

  up :: List (TreeContext k v) -> KickUp k v -> Map k v
  up Nil (KickUp left k v right) = Two left k v right
  up (Cons x ctx) (KickUp m1 k v m2) =
    case x of
      TwoLeft k1 v1 right -> fromZipper ctx (Three m1 k v m2 k1 v1 right)
      TwoRight left k1 v1 -> fromZipper ctx (Three left k1 v1 m1 k v m2)
      ThreeLeft k1 v1 c k2 v2 d -> up ctx (KickUp (Two m1 k v m2) k1 v1 (Two c k2 v2 d))
      ThreeMiddle a k1 v1 k2 v2 d -> up ctx (KickUp (Two a k1 v1 m1) k v (Two m2 k2 v2 d))
      ThreeRight a k1 v1 b k2 v2 -> up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two m1 k v m2))

-- | Delete a key and its corresponding value from a map
delete :: forall k v. (Ord k) => k -> Map k v -> Map k v
delete = down Nil
  where
  down :: List (TreeContext k v) -> k -> Map k v -> Map k v
  down ctx _ Leaf = fromZipper ctx Leaf
  down ctx k (Two Leaf k1 _ Leaf)
    | k == k1 = up ctx Leaf
  down ctx k (Two left k1 v1 right)
    | k == k1   = let max = maxNode left
                    in removeMaxNode (Cons (TwoLeft max.key max.value right) ctx) left
    | k < k1    = down (Cons (TwoLeft k1 v1 right) ctx) k left
    | otherwise = down (Cons (TwoRight left k1 v1) ctx) k right
  down ctx k (Three Leaf k1 v1 Leaf k2 v2 Leaf)
    | k == k1 = fromZipper ctx (Two Leaf k2 v2 Leaf)
    | k == k2 = fromZipper ctx (Two Leaf k1 v1 Leaf)
  down ctx k (Three left k1 v1 mid k2 v2 right)
    | k == k1 = let max = maxNode left
                  in removeMaxNode (Cons (ThreeLeft max.key max.value mid k2 v2 right) ctx) left
    | k == k2 = let max = maxNode mid
                  in removeMaxNode (Cons (ThreeMiddle left k1 v1 max.key max.value right) ctx) mid
    | k < k1               = down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k left
    | k1 < k && k < k2 = down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k mid
    | otherwise            = down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k right

  up :: List (TreeContext k v) -> Map k v -> Map k v
  up Nil tree = tree
  up (Cons (TwoLeft k1 v1 Leaf) ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (Cons (TwoRight Leaf k1 v1) ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (Cons (TwoLeft k1 v1 (Two m k2 v2 r)) ctx) l = up ctx (Three l k1 v1 m k2 v2 r)
  up (Cons (TwoRight (Two l k1 v1 m) k2 v2) ctx) r = up ctx (Three l k1 v1 m k2 v2 r)
  up (Cons (TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d)) ctx) a = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (Cons (TwoRight (Three a k1 v1 b k2 v2 c) k3 v3) ctx) d = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (Cons (ThreeLeft k1 v1 Leaf k2 v2 Leaf) ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (Cons (ThreeMiddle Leaf k1 v1 k2 v2 Leaf) ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (Cons (ThreeRight Leaf k1 v1 Leaf k2 v2) ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (Cons (ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d) ctx) a = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (Cons (ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d) ctx) c = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (Cons (ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d)) ctx) b = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (Cons (ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3) ctx) d = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (Cons (ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e) ctx) a = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (Cons (ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e) ctx) d = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (Cons (ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e)) ctx) b = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
  up (Cons (ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4) ctx) e = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
  up _ _ = unsafeThrow "Impossible case in 'up'"

  maxNode :: Map k v -> { key :: k, value :: v }
  maxNode (Two _ k v Leaf) = { key: k, value: v }
  maxNode (Two _ _ _ right) = maxNode right
  maxNode (Three _ _ _ _ k v Leaf) = { key: k, value: v }
  maxNode (Three _ _ _ _ _ _ right) = maxNode right
  maxNode Leaf = unsafeThrow "Impossible case in 'maxNode'"

  removeMaxNode :: List (TreeContext k v) -> Map k v -> Map k v
  removeMaxNode ctx (Two Leaf _ _ Leaf) = up ctx Leaf
  removeMaxNode ctx (Two left k v right) = removeMaxNode (Cons (TwoRight left k v) ctx) right
  removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf) = up (Cons (TwoRight Leaf k1 v1) ctx) Leaf
  removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right
  removeMaxNode _ Leaf = unsafeThrow "Impossible case in 'removeMaxNode'"

-- | Insert the value, delete a value, or update a value for a key in a map
alter :: forall k v. (Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Update or delete the value for a key in a map
update :: forall k v. (Ord k) => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, later values take precedence over earlier ones.
fromFoldable :: forall f k v. (Ord k, Foldable f) => f (Tuple k v) -> Map k v
fromFoldable = foldl (\m (Tuple k v) -> insert k v m) empty

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, the values are configurably combined.
fromFoldableWith :: forall f k v. (Ord k, Foldable f) => (v -> v -> v) -> f (Tuple k v) -> Map k v
fromFoldableWith f = foldl (\m (Tuple k v) -> alter (combine v) k m) empty where
  combine v (Just v') = Just $ f v v'
  combine v Nothing = Just v

-- | Convert a map to a list of key/value pairs
toList :: forall k v. Map k v -> List (Tuple k v)
toList Leaf = Nil
toList (Two left k v right) = toList left ++ pure (Tuple k v) ++ toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left ++ pure (Tuple k1 v1) ++ toList mid ++ pure (Tuple k2 v2) ++ toList right

-- | Create a map from a list of key/value pairs
fromList :: forall k v. (Ord k) => List (Tuple k v) -> Map k v
fromList = fromFoldable

-- | Create a map from a list of key/value pairs, using the specified function
-- | to combine values for duplicate keys.
fromListWith :: forall k v. (Ord k) => (v -> v -> v) -> List (Tuple k v) -> Map k v
fromListWith = fromFoldableWith

-- | Get a list of the keys contained in a map
keys :: forall k v. Map k v -> List k
keys Leaf = Nil
keys (Two left k _ right) = keys left ++ pure k ++ keys right
keys (Three left k1 _ mid k2 _ right) = keys left ++ pure k1 ++ keys mid ++ pure k2 ++ keys right

-- | Get a list of the values contained in a map
values :: forall k v. Map k v -> List v
values Leaf = Nil
values (Two left _ v right) = values left ++ pure v ++ values right
values (Three left _ v1 mid _ v2 right) = values left ++ pure v1 ++ values mid ++ pure v2 ++ values right

-- | Compute the union of two maps, using the specified function
-- | to combine values for duplicate keys.
unionWith :: forall k v. (Ord k) => (v -> v -> v) -> Map k v -> Map k v -> Map k v
unionWith f m1 m2 = foldl go m2 (toList m1)
  where
  go m (Tuple k v) = alter (Just <<< maybe v (f v)) k m

-- | Compute the union of two maps, preferring values from the first map in the case
-- | of duplicate keys
union :: forall k v. (Ord k) => Map k v -> Map k v -> Map k v
union = unionWith const

-- | Compute the union of a collection of maps
unions :: forall k v f. (Ord k, Foldable f) => f (Map k v) -> Map k v
unions = foldl union empty

-- | Calculate the number of key/value pairs in a map
size :: forall k v. Map k v -> Int
size = length <<< values

-- | This module defines a type of maps as balanced 2-3 trees, based on
-- | <http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf>

module Data.Map
  ( Map()
  , showTree
  , empty
  , isEmpty
  , singleton
  , checkValid
  , insert
  , lookup
  , fromFoldable
  , fromFoldableWith
  , toList
  , fromList
  , fromListWith
  , delete
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  ) where

import Prelude

import Data.Foldable (foldl, foldMap, foldr, Foldable)
import Data.List (List(..), length, nub)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Maybe.Unsafe (unsafeThrow)
import Data.Monoid (Monoid)
import Data.Traversable (traverse, Traversable)
import Data.Tuple (Tuple(..), uncurry)

-- | `Map k v` represents maps from keys of type `k` to values of type `v`.
data Map k v
  = Leaf
  | Two (Map k v) k v (Map k v)
  | Three (Map k v) k v (Map k v) k v (Map k v)

instance eqMap :: (Eq k, Eq v) => Eq (Map k v) where
  eq m1 m2 = toList m1 == toList m2

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "fromList " ++ show (toList m)

instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where
  compare m1 m2 = compare (toList m1) (toList m2)

instance semigroupMap :: (Ord k) => Semigroup (Map k v) where
  append = union

instance monoidMap :: (Ord k) => Monoid (Map k v) where
  mempty = empty

instance functorMap :: Functor (Map k) where
  map _ Leaf = Leaf
  map f (Two left k v right) = Two (map f left) k (f v) (map f right)
  map f (Three left k1 v1 mid k2 v2 right) = Three (map f left) k1 (f v1) (map f mid) k2 (f v2) (map f right)

instance foldableMap :: Foldable (Map k) where
  foldl   f z m = foldl   f z (values m)
  foldr   f z m = foldr   f z (values m)
  foldMap f   m = foldMap f   (values m)

instance traversableMap :: (Ord k) => Traversable (Map k) where
  traverse f ms = foldr (\x acc -> union <$> x <*> acc) (pure empty) (((<$>) (uncurry singleton)) <$> (traverse f <$> toList ms))
  sequence = traverse id

-- | Render a `Map` as a `String`
showTree :: forall k v. (Show k, Show v) => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
  "Two (" ++ showTree left ++
  ") (" ++ show k ++
  ") (" ++ show v ++
  ") (" ++ showTree right ++ ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" ++ showTree left ++
  ") (" ++ show k1 ++
  ") (" ++ show v1 ++
  ") (" ++ showTree mid ++
  ") (" ++ show k2 ++
  ") (" ++ show v2 ++
  ") (" ++ showTree right ++ ")"

-- | An empty map
empty :: forall k v. Map k v
empty = Leaf

-- | Test if a map is empty
isEmpty :: forall k v. Map k v -> Boolean
isEmpty Leaf = true
isEmpty _ = false

-- | Create a map with one key/value pair
singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

-- | Check whether the underlying tree satisfies the 2-3 invariant
-- |
-- | This function is provided for internal use.
checkValid :: forall k v. Map k v -> Boolean
checkValid tree = length (nub (allHeights tree)) == one
  where
  allHeights :: Map k v -> List Int
  allHeights Leaf = pure zero
  allHeights (Two left _ _ right) = map (\n -> n + one) (allHeights left ++ allHeights right)
  allHeights (Three left _ _ mid _ _ right) = map (\n -> n + one) (allHeights left ++ allHeights mid ++ allHeights right)

-- | Lookup a value for the specified key
lookup :: forall k v. (Ord k) => k -> Map k v -> Maybe v
lookup _ Leaf = Nothing
lookup k (Two _ k1 v _) | k == k1 = Just v
lookup k (Two left k1 _ _) | k < k1 = lookup k left
lookup k (Two _ _ _ right) = lookup k right
lookup k (Three _ k1 v1 _ _ _ _) | k == k1 = Just v1
lookup k (Three _ _ _ _ k2 v2 _) | k == k2 = Just v2
lookup k (Three left k1 _ _ _ _ _) | k < k1 = lookup k left
lookup k (Three _ k1 _ mid k2 _ _) | k1 < k && k <= k2 = lookup k mid
lookup k (Three _ _ _ _ _ _ right) = lookup k right

-- | Test if a key is a member of a map
member :: forall k v. (Ord k) => k -> Map k v -> Boolean
member k m = isJust (k `lookup` m)

data TreeContext k v
  = TwoLeft k v (Map k v)
  | TwoRight (Map k v) k v
  | ThreeLeft k v (Map k v) k v (Map k v)
  | ThreeMiddle (Map k v) k v k v (Map k v)
  | ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. (Ord k) => List (TreeContext k v) -> Map k v -> Map k v
fromZipper Nil tree = tree
fromZipper (Cons (TwoLeft k1 v1 right) ctx) left = fromZipper ctx (Two left k1 v1 right)
fromZipper (Cons (TwoRight left k1 v1) ctx) right = fromZipper ctx (Two left k1 v1 right)
fromZipper (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) left = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) mid = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right = fromZipper ctx (Three left k1 v1 mid k2 v2 right)

data KickUp k v = KickUp (Map k v) k v (Map k v)

-- | Insert a key/value pair into a map
insert :: forall k v. (Ord k) => k -> v -> Map k v -> Map k v
insert = down Nil
  where
  down :: List (TreeContext k v) -> k -> v -> Map k v -> Map k v
  down ctx k v Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx k v (Two left k1 _ right) | k == k1 = fromZipper ctx (Two left k v right)
  down ctx k v (Two left k1 v1 right) | k < k1 = down (Cons (TwoLeft k1 v1 right) ctx) k v left
  down ctx k v (Two left k1 v1 right) = down (Cons (TwoRight left k1 v1) ctx) k v right
  down ctx k v (Three left k1 _ mid k2 v2 right) | k == k1 = fromZipper ctx (Three left k v mid k2 v2 right)
  down ctx k v (Three left k1 v1 mid k2 _ right) | k == k2 = fromZipper ctx (Three left k1 v1 mid k v right)
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k < k1 = down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k v left
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k1 < k && k <= k2 = down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k v mid
  down ctx k v (Three left k1 v1 mid k2 v2 right) = down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k v right

  up :: List (TreeContext k v) -> KickUp k v -> Map k v
  up Nil (KickUp left k v right) = Two left k v right
  up (Cons (TwoLeft k1 v1 right) ctx) (KickUp left k v mid) = fromZipper ctx (Three left k v mid k1 v1 right)
  up (Cons (TwoRight left k1 v1) ctx) (KickUp mid k v right) = fromZipper ctx (Three left k1 v1 mid k v right)
  up (Cons (ThreeLeft k1 v1 c k2 v2 d) ctx) (KickUp a k v b) = up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
  up (Cons (ThreeMiddle a k1 v1 k2 v2 d) ctx) (KickUp b k v c) = up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
  up (Cons (ThreeRight a k1 v1 b k2 v2) ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))

-- | Delete a key and its corresponding value from a map
delete :: forall k v. (Ord k) => k -> Map k v -> Map k v
delete = down Nil
  where
  down :: List (TreeContext k v) -> k -> Map k v -> Map k v
  down ctx _ Leaf = fromZipper ctx Leaf
  down ctx k (Two Leaf k1 _ Leaf)
    | k == k1 = up ctx Leaf
  down ctx k (Two left k1 v1 right)
    | k == k1   = let max = maxNode left
                    in removeMaxNode (Cons (TwoLeft max.key max.value right) ctx) left
    | k < k1    = down (Cons (TwoLeft k1 v1 right) ctx) k left
    | otherwise = down (Cons (TwoRight left k1 v1) ctx) k right
  down ctx k (Three Leaf k1 v1 Leaf k2 v2 Leaf)
    | k == k1 = fromZipper ctx (Two Leaf k2 v2 Leaf)
    | k == k2 = fromZipper ctx (Two Leaf k1 v1 Leaf)
  down ctx k (Three left k1 v1 mid k2 v2 right)
    | k == k1 = let max = maxNode left
                  in removeMaxNode (Cons (ThreeLeft max.key max.value mid k2 v2 right) ctx) left
    | k == k2 = let max = maxNode mid
                  in removeMaxNode (Cons (ThreeMiddle left k1 v1 max.key max.value right) ctx) mid
    | k < k1               = down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k left
    | k1 < k && k < k2 = down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k mid
    | otherwise            = down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k right

  up :: List (TreeContext k v) -> Map k v -> Map k v
  up Nil tree = tree
  up (Cons (TwoLeft k1 v1 Leaf) ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (Cons (TwoRight Leaf k1 v1) ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (Cons (TwoLeft k1 v1 (Two m k2 v2 r)) ctx) l = up ctx (Three l k1 v1 m k2 v2 r)
  up (Cons (TwoRight (Two l k1 v1 m) k2 v2) ctx) r = up ctx (Three l k1 v1 m k2 v2 r)
  up (Cons (TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d)) ctx) a = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (Cons (TwoRight (Three a k1 v1 b k2 v2 c) k3 v3) ctx) d = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (Cons (ThreeLeft k1 v1 Leaf k2 v2 Leaf) ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (Cons (ThreeMiddle Leaf k1 v1 k2 v2 Leaf) ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (Cons (ThreeRight Leaf k1 v1 Leaf k2 v2) ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (Cons (ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d) ctx) a = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (Cons (ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d) ctx) c = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (Cons (ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d)) ctx) b = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (Cons (ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3) ctx) d = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (Cons (ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e) ctx) a = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (Cons (ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e) ctx) d = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (Cons (ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e)) ctx) b = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
  up (Cons (ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4) ctx) e = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
  up _ _ = unsafeThrow "Impossible case in 'up'"

  maxNode :: Map k v -> { key :: k, value :: v }
  maxNode (Two _ k v Leaf) = { key: k, value: v }
  maxNode (Two _ _ _ right) = maxNode right
  maxNode (Three _ _ _ _ k v Leaf) = { key: k, value: v }
  maxNode (Three _ _ _ _ _ _ right) = maxNode right
  maxNode Leaf = unsafeThrow "Impossible case in 'maxNode'"

  removeMaxNode :: List (TreeContext k v) -> Map k v -> Map k v
  removeMaxNode ctx (Two Leaf _ _ Leaf) = up ctx Leaf
  removeMaxNode ctx (Two left k v right) = removeMaxNode (Cons (TwoRight left k v) ctx) right
  removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf) = up (Cons (TwoRight Leaf k1 v1) ctx) Leaf
  removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right
  removeMaxNode _ Leaf = unsafeThrow "Impossible case in 'removeMaxNode'"

-- | Insert the value, delete a value, or update a value for a key in a map
alter :: forall k v. (Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Update or delete the value for a key in a map
update :: forall k v. (Ord k) => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, later values take precedence over earlier ones.
fromFoldable :: forall f k v. (Ord k, Foldable f) => f (Tuple k v) -> Map k v
fromFoldable = foldl (\m (Tuple k v) -> insert k v m) empty

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, the values are configurably combined.
fromFoldableWith :: forall f k v. (Ord k, Foldable f) => (v -> v -> v) -> f (Tuple k v) -> Map k v
fromFoldableWith f = foldl (\m (Tuple k v) -> alter (combine v) k m) empty where
  combine v (Just v') = Just $ f v v'
  combine v Nothing = Just v

-- | Convert a map to a list of key/value pairs
toList :: forall k v. Map k v -> List (Tuple k v)
toList Leaf = Nil
toList (Two left k v right) = toList left ++ pure (Tuple k v) ++ toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left ++ pure (Tuple k1 v1) ++ toList mid ++ pure (Tuple k2 v2) ++ toList right

-- | Create a map from a list of key/value pairs
fromList :: forall k v. (Ord k) => List (Tuple k v) -> Map k v
fromList = fromFoldable

-- | Create a map from a list of key/value pairs, using the specified function
-- | to combine values for duplicate keys.
fromListWith :: forall k v. (Ord k) => (v -> v -> v) -> List (Tuple k v) -> Map k v
fromListWith = fromFoldableWith

-- | Get a list of the keys contained in a map
keys :: forall k v. Map k v -> List k
keys Leaf = Nil
keys (Two left k _ right) = keys left ++ pure k ++ keys right
keys (Three left k1 _ mid k2 _ right) = keys left ++ pure k1 ++ keys mid ++ pure k2 ++ keys right

-- | Get a list of the values contained in a map
values :: forall k v. Map k v -> List v
values Leaf = Nil
values (Two left _ v right) = values left ++ pure v ++ values right
values (Three left _ v1 mid _ v2 right) = values left ++ pure v1 ++ values mid ++ pure v2 ++ values right

-- | Compute the union of two maps, using the specified function
-- | to combine values for duplicate keys.
unionWith :: forall k v. (Ord k) => (v -> v -> v) -> Map k v -> Map k v -> Map k v
unionWith f m1 m2 = foldl go m2 (toList m1)
  where
  go m (Tuple k v) = alter (Just <<< maybe v (f v)) k m

-- | Compute the union of two maps, preferring values from the first map in the case
-- | of duplicate keys
union :: forall k v. (Ord k) => Map k v -> Map k v -> Map k v
union = unionWith const

-- | Compute the union of a collection of maps
unions :: forall k v f. (Ord k, Foldable f) => f (Map k v) -> Map k v
unions = foldl union empty

-- | Calculate the number of key/value pairs in a map
size :: forall k v. Map k v -> Int
size = length <<< values