Typechecker, half done

Typechecker, half done

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.TypeChecker
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- The top-level type checker, which checks all declarations in a module.
--
-----------------------------------------------------------------------------

module Language.PureScript.TypeChecker (typeCheckAll) where

import Data.Maybe
import Data.Array
import Data.Foldable (for_, foldl, foldr)

import Data.Tuple
import Data.Tuple3

import qualified Data.Map as M

import Control.Monad
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.Error
import Control.Monad.Error.Class

import Language.PureScript.Types
import Language.PureScript.Names
import Language.PureScript.Kinds
import Language.PureScript.Declarations
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Environment
import Language.PureScript.Errors

import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Types
import Language.PureScript.TypeChecker.Kinds

addDataType :: ModuleName -> ProperName -> [String] -> [Tuple ProperName [Type]] -> Kind -> Check {}
addDataType moduleName name args dctors ctorKind = do
  modifyEnv $ \(Environment env) -> Environment (env { types = M.insert (Qualified (Just moduleName) name) (Tuple ctorKind (DataType args dctors)) env.types })
  for_ dctors $ \(Tuple dctor tys) ->
    rethrow (\e -> strMsg ("Error in data constructor " ++ show dctor) <> (e :: ErrorStack)) $
      addDataConstructor moduleName name args dctor tys

addDataConstructor :: ModuleName -> ProperName -> [String] -> ProperName -> [Type] -> Check {}
addDataConstructor moduleName name args dctor tys = do
  let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
  let dctorTy = foldr function retTy tys
  let polyType = mkForAll args dctorTy
  modifyEnv $ \(Environment env) -> Environment (env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (Tuple name polyType) env.dataConstructors })

addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check {}
addTypeSynonym moduleName name args ty kind = do
  modifyEnv $ \(Environment env) -> Environment (env { types = M.insert (Qualified (Just moduleName) name) (Tuple kind TypeSynonym) env.types
                                                     , typeSynonyms = M.insert (Qualified (Just moduleName) name) (Tuple args ty) env.typeSynonyms })

valueIsNotDefined :: ModuleName -> Ident -> Check {}
valueIsNotDefined moduleName name = do
  Environment env <- getEnv
  case M.lookup (Tuple moduleName name) env.names of
    Just _ -> throwError (strMsg (show name ++ " is already defined") :: ErrorStack)
    Nothing -> return {}

addValue :: ModuleName -> Ident -> Type -> NameKind -> Check {}
addValue moduleName name ty nameKind =
  modifyEnv $ \(Environment env) -> Environment (env { names = M.insert (Tuple moduleName name) (Tuple ty nameKind) env.names })

addTypeClass :: ModuleName -> ProperName -> [String] -> [Tuple (Qualified ProperName) [Type]] -> [Declaration] -> Check {}
addTypeClass moduleName pn args implies ds =
  let members = map toPair ds in
  modifyEnv $ \(Environment env) -> Environment (env { typeClasses = M.insert (Qualified (Just moduleName) pn) (Tuple3 args members implies) env.typeClasses })
  where
  toPair (TypeDeclaration ident ty) = Tuple ident ty
  toPair (PositionedDeclaration _ d) = toPair d
  toPair _ = theImpossibleHappened "Invalid declaration in TypeClassDeclaration"

addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check {}
addTypeClassDictionaries entries =
  let mentries = M.fromList $
    do (entry@(TypeClassDictionaryInScope { name = Qualified mn _ })) <- entries
       return (Tuple (Tuple (canonicalizeDictionary entry) mn) entry)
  in modifyEnv $ \(Environment env) -> Environment (env { typeClassDictionaries = env.typeClassDictionaries `M.union` mentries })

checkTypeClassInstance :: ModuleName -> Type -> Check {}
checkTypeClassInstance _ (TypeVar _) = return {}
checkTypeClassInstance _ (TypeConstructor ctor) = do
  Environment env <- getEnv
  when (ctor `M.member` env.typeSynonyms) $ throwError (strMsg "Type synonym instances are disallowed" :: ErrorStack)
checkTypeClassInstance m (TypeApp t1 t2) = do
  checkTypeClassInstance m t1
  checkTypeClassInstance m t2
checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty))

-- |
-- Type check all declarations in a module
--
-- At this point, many declarations will have been desugared, but it is still necessary to
--
--  * Kind-check all types and add them to the @Environment@
--
--  * Type-check all values and add them to the @Environment@
--
--  * Bring type class instances into scope
--
--  * Process module imports
--
foreign import typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declaration]
{-
typeCheckAll _ _ [] = return []
typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do
  rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do
    ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
    addDataType moduleName name args dctors ctorKind
  ds <- typeCheckAll mainModuleName moduleName rest
  return $ d : ds
typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do
  rethrow (strMsg "Error in data binding group" <>) $ do
    let syns = mapMaybe toTypeSynonym tys
    let dataDecls = mapMaybe toDataDecl tys
    (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
    for_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) ->
      addDataType moduleName name args dctors ctorKind
    for_ (zip syns syn_ks) $ \((name, args, ty), kind) ->
      addTypeSynonym moduleName name args ty kind
  ds <- typeCheckAll mainModuleName moduleName rest
  return $ d : ds
  where
  toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
  toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'
  toTypeSynonym _ = Nothing
  toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)
  toDataDecl (PositionedDeclaration _ d') = toDataDecl d'
  toDataDecl _ = Nothing
typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
  rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
    kind <- kindsOf False moduleName name args [ty]
    addTypeSynonym moduleName name args ty kind
  ds <- typeCheckAll mainModuleName moduleName rest
  return $ d : ds
typeCheckAll _ _ (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
typeCheckAll mainModuleName moduleName (ValueDeclaration name nameKind [] Nothing val : rest) = do
  d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do
    valueIsNotDefined moduleName name
    [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
    addValue moduleName name ty nameKind
    return $ ValueDeclaration name nameKind [] Nothing val'
  ds <- typeCheckAll mainModuleName moduleName rest
  return $ d : ds
typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"
typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do
  d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do
    for_ (map (\(ident, _, _) -> ident) vals) $ \name ->
      valueIsNotDefined moduleName name
    tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
    vals' <- for (zipWith (\(name, nameKind, _) (_, (val, ty)) -> (name, val, nameKind, ty)) vals tys) $ \(name, val, nameKind, ty) -> do
      addValue moduleName name ty nameKind
      return (name, nameKind, val)
    return $ BindingGroupDeclaration vals'
  ds <- typeCheckAll mainModuleName moduleName rest
  return $ d : ds
typeCheckAll mainModuleName moduleName (d@(ExternDataDeclaration name kind) : rest) = do
  env <- getEnv
  putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
  ds <- typeCheckAll mainModuleName moduleName rest
  return $ d : ds
typeCheckAll mainModuleName moduleName (d@(ExternDeclaration importTy name _ ty) : rest) = do
  rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do
    env <- getEnv
    kind <- kindOf moduleName ty
    guardWith (strMsg "Expected kind *") $ kind == Star
    case M.lookup (moduleName, name) (names env) of
      Just _ -> throwError . strMsg $ show name ++ " is already defined"
      Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy) (names env) })
  ds <- typeCheckAll mainModuleName moduleName rest
  return $ d : ds
typeCheckAll mainModuleName moduleName (d@(FixityDeclaration _ name) : rest) = do
  ds <- typeCheckAll mainModuleName moduleName rest
  env <- getEnv
  guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
  return $ d : ds
typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName _ _) : rest) = do
  tcds <- getTypeClassDictionaries
  let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in moduleName == mn) tcds
  addTypeClassDictionaries [ tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }
                           | tcd <- instances
                           , let (Qualified _ ident) = tcdName tcd
                           ]
  ds <- typeCheckAll mainModuleName currentModule rest
  return $ d : ds
typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration pn args implies tys) : rest) = do
  addTypeClass moduleName pn args implies tys
  ds <- typeCheckAll mainModuleName moduleName rest
  return $ d : ds
typeCheckAll mainModuleName moduleName (TypeInstanceDeclaration dictName deps className tys _ : rest) = do
  typeCheckAll mainModuleName moduleName (ExternInstanceDeclaration dictName deps className tys : rest)
typeCheckAll mainModuleName moduleName (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
  mapM_ (checkTypeClassInstance moduleName) tys
  for_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
  addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]
  ds <- typeCheckAll mainModuleName moduleName rest
  return $ d : ds
typeCheckAll mainModuleName moduleName (PositionedDeclaration pos d : rest) =
  rethrowWithPosition pos $ do
    (d' : rest') <- typeCheckAll mainModuleName moduleName (d : rest)
    return (PositionedDeclaration pos d' : rest')
-}

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


Display address in fund request

Display address in fund request

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/clample/lambdabtc.git/'


Need to import Ordering after master rebase. Prelude won't export ++ anymore as of 1.0.0-rc.1

-- | 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 (class Ord, class Show, class Functor, class Semigroup, class Eq, (<<<), const, pure, ($), otherwise, (<), (&&), (==), one, (+), map, zero, show, id, (<$>), (<*>), compare, Ordering(..), append)

import Data.Foldable (foldl, foldMap, foldr, class Foldable)
import Data.List (List(..), length, nub)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Maybe.Unsafe (unsafeThrow)
import Data.Monoid (class Monoid)
import Data.Traversable (traverse, class 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 " `append` 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 (" `append` showTree left `append`
  ") (" `append` show k `append`
  ") (" `append` show v `append`
  ") (" `append` showTree right `append` ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" `append` showTree left `append`
  ") (" `append` show k1 `append`
  ") (" `append` show v1 `append`
  ") (" `append` showTree mid `append`
  ") (" `append` show k2 `append`
  ") (" `append` show v2 `append`
  ") (" `append` showTree right `append` ")"

-- | 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 `append` allHeights right)
  allHeights (Three left _ _ mid _ _ right) = map (\n -> n + one) (allHeights left `append` allHeights mid `append` 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 `append` pure (Tuple k v) `append` toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left `append` pure (Tuple k1 v1) `append` toList mid `append` pure (Tuple k2 v2) `append` 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 `append` pure k `append` keys right
keys (Three left k1 _ mid k2 _ right) = keys left `append` pure k1 `append` keys mid `append` pure k2 `append` 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 `append` pure v `append` values right
values (Three left _ v1 mid _ v2 right) = values left `append` pure v1 `append` values mid `append` pure v2 `append` 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 (class Ord, class Show, class Functor, class Semigroup, class Eq, (<<<), const, pure, (++), ($), otherwise, (<), (&&), (==), (<=), one, (+), map, zero, show, id, (<$>), (<*>), compare)

import Data.Foldable (foldl, foldMap, foldr, class Foldable)
import Data.List (List(..), length, nub)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Maybe.Unsafe (unsafeThrow)
import Data.Monoid (class Monoid)
import Data.Traversable (traverse, class 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


Let's get a Pux style update function! :-)

-- | Gonimo specific Pux helpers and replacements for defaults.

module Gonimo.Pux where

import Prelude
import Gonimo.Client.Types as Gonimo
import Control.Alternative (empty, class Alternative)
import Control.Monad.Aff (Aff)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (class MonadIO, liftIO)
import Control.Monad.Maybe.Trans (runMaybeT, MaybeT(MaybeT))
import Control.Monad.Reader.Class (local, ask, class MonadReader)
import Control.Monad.Reader.Trans (runReaderT, ReaderT(ReaderT))
import Control.Monad.State (State)
import Control.Monad.State.Class (modify, put, get, state, class MonadState)
import Control.Monad.State.Trans (runStateT, StateT(StateT))
import Control.Monad.Trans (lift, class MonadTrans)
import Data.Bifunctor (bimap, class Bifunctor)
import Data.Identity (runIdentity)
import Data.Lens (SetterP, APrismP, (.=), prism, (^?), PrismP, (.~), (^.), LensP)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (GonimoEff, Gonimo, Settings, class ReportErrorAction)
import Partial.Unsafe (unsafeCrashWith)
import Gonimo.Util (runIOToSomeAff)

-- First this was a record but records containing prisms is something psc does not seem to like.
-- | A helper data structure for transforming child components to parent components:
data ChildData parentState childState childProps =
  ChildData (PrismP parentState childState) childProps

makeChildData :: forall parentState childState childProps. PrismP parentState childState -> childProps -> (ChildData parentState childState childProps)
makeChildData fromToParent props = ChildData fromToParent props

childDataFromToParent :: forall parentState childState childProps.
                         ChildData parentState childState childProps
                         -> PrismP parentState childState
childDataFromToParent (ChildData fromToParent _) = fromToParent

childDataProps :: forall parentState childState childProps.
                         ChildData parentState childState childProps
                         -> childProps
childDataProps (ChildData _ props) = props

-- | Create ChildData from a parent component:
type ToChild parentProps parentState childProps childState m =
  (MonadReader parentProps m, MonadState parentState m)
  => m (ChildData parentState childState childProps)

-- | A component is just a Reader monad with react style props and a State monad
-- | with well our component state.
newtype Component props state a = Component (ReaderT props (State state) a)

-- | Stateful Update function which can be converted to a Pux eff model ...
type Update props state action = action -> Component props state (Array (IO action))

runComponent :: forall props state a. Component props state a -> ReaderT props (State state) a
runComponent (Component m) = m

runComponentFull :: forall props state a. props -> state -> Component props state a -> Tuple a state
runComponentFull props state = runIdentity <<< flip runStateT state <<< flip runReaderT props <<< runComponent

-- | Run a child component and transform it to a parent component, updating the
-- | state only if it actually changed.
-- | We return Nothing if the child is currently not present in the parent.
liftChild :: forall childProps childState parentProps parentState m a.
            ( MonadReader parentProps m
            , MonadState parentState m
            )
            => ToChild parentProps parentState childProps childState m
            -> Component childProps childState a
            -> m (Maybe a)
liftChild toChild child = do
  childData <- toChild
  oldParent <- get
  let
    fromToParent = childDataFromToParent childData
    childProps   = childDataProps childData

    runComponentCheck :: childState -> m a
    runComponentCheck oldChild = do
      case runComponentFull childProps oldChild child of
        Tuple a newChild -> do
          when (differentObject newChild oldChild)
            $ fromToParent .= newChild
          pure a
  traverse runComponentCheck (oldParent ^? fromToParent)

-- | Convert a component to an EffModel usable with Pux.
-- | The restriction to of props to Unit for this root component is currently not justified
-- | and can be dropped if necessary. I just have some vague idea for future enhancements where
-- | properties for the root level component could be in the way.
toEffModel :: forall state action eff. state -> Component Unit state (Array (IO action)) -> EffModelImpl state action eff
toEffModel initState c =
  case runComponentFull unit initState c of
    Tuple effects state -> { state : state
                           , effects : runIOToSomeAff <$> effects
                           }

-- | We are still using Pux - so let's a get a Pux like Update function which provides an EffModel ...
toPuxUpdate :: forall state action eff. Update Unit state action -> action -> state -> EffModelImpl state action eff
toPuxUpdate update action state = toEffModel state $ update action

instance functorComponent :: Functor (Component props state) where
  map f (Component m) = Component $ map f m

instance applyComponent :: Apply (Component props state) where
  apply (Component mf) (Component ma) = Component $ apply mf ma

instance applicativeComponent :: Applicative (Component props state) where
  pure = Component <<< pure

instance bindComponent :: Bind (Component props state) where
  bind (Component ma) mf = Component $ bind ma (runComponent <<< mf)

instance monadComponent :: Monad (Component props state)

instance monadReaderPropsComponent :: MonadReader props (Component props state) where
  ask = Component ask
  --local :: forall a. (r -> r) -> m a -> m a
  local f (Component ma) = Component (local f ma)

instance monadStateStateComponent :: MonadState state (Component props state) where
  -- get = Component <<< MaybeT <<< runMaybeT <<< ReaderT <<< flip runReaderT
  --       <<< StateT $ \ s -> runStateT (pure s) s
  state f = Component $ state f

type EffModelImpl state action eff =
  { state :: state
  , effects :: Array (Aff (GonimoEff eff) action)
  }

newtype EffModel eff state action = EffModel (EffModelImpl state action eff)

runEffModel :: forall state action eff. EffModel eff state action -> EffModelImpl state action eff
runEffModel (EffModel model) = model

instance bifunctorEffModelEff :: Bifunctor (EffModel eff) where
  bimap f g (EffModel model) = EffModel
    { state : f model.state
    , effects : map (map g) model.effects
    }

updateChild :: forall eff parentState childState parentAction childAction props.
            LensP parentState childState
            -> (childAction -> parentAction)
            -> (props -> childAction -> childState -> EffModel eff childState childAction)
            -> props -> childAction -> parentState -> EffModel eff parentState parentAction
updateChild lens mkAction childUpdate props action state =
    bimap smartUpdate mkAction $ childUpdate props action (state ^. lens)
  where
    smartUpdate :: childState -> parentState
    smartUpdate newChild =if differentObject newChild (state ^. lens)
                          then state # lens .~ newChild
                          else  state

updatePrismChild :: forall eff parentState childState parentAction childAction props.
            PrismP parentState childState
            -> (childAction -> parentAction)
            -> (props -> childAction -> childState -> EffModel eff childState childAction)
            -> props -> childAction -> parentState -> Maybe (EffModel eff parentState parentAction)
updatePrismChild prism mkAction childUpdate props action state =
    bimap smartUpdate mkAction <<< childUpdate props action <$> state ^? prism
  where
    smartUpdate :: childState -> parentState
    smartUpdate newChild = case state ^? prism of
                                Nothing -> state
                                Just oldChild -> if differentObject newChild oldChild
                                                    then state # prism .~ newChild
                                                    else state

-- toParent :: forall eff parentState childState parentAction childAction.
--             LensP parentState childState
--             -> (childAction -> parentAction)
--             -> parentState -> EffModel eff childState childAction
--             -> EffModel eff parentState parentAction
-- toParent lens mkAction state = bimap smartUpdate mkAction
--   where
--     smartUpdate :: childState -> parentState
--     smartUpdate newChild = if differentObject newChild (state ^. lens)
--                            then lens .~ newChild $ state
--                            else state

onlyEffects :: forall state action eff
               .  state -> Array (Aff (GonimoEff eff) action)
               -> EffModel eff state action
onlyEffects state effects = EffModel { state : state
                                     , effects : effects
                                     }

-- | Like `onlyEffects` but for a single effect
onlyEffect :: forall state action eff
               . state -> Aff (GonimoEff eff) action
               -> EffModel eff state action
onlyEffect state eff = onlyEffects state [eff]

-- | Like onlyEffects but with arguments flipped
justEffects :: forall state action eff
               .  Array (Aff (GonimoEff eff) action)
               -> state -> EffModel eff state action
justEffects = flip onlyEffects

-- | Like `justEffects` but for a single effect
justEffect :: forall state action eff
               .  Aff (GonimoEff eff) action
               -> state -> EffModel eff state action
justEffect eff = justEffects [eff]

noEffects :: forall state action eff. state -> EffModel eff state action
noEffects state = EffModel { state : state, effects : [] }

type Props ps = { settings :: Settings | ps }

onlyGonimos :: forall state action eff ps
               . ReportErrorAction action => Props ps -> state -> Array (Gonimo eff action)
               -> EffModel eff state action
onlyGonimos props state = onlyEffects state <<< map (Gonimo.toAff props.settings)

-- | Like `onlyGonimos` but for a single effect
onlyGonimo :: forall state action eff ps
               . ReportErrorAction action => Props ps -> state -> Gonimo eff action
               -> EffModel eff state action
onlyGonimo props state eff = onlyGonimos props state [eff]

-- | Like onlyGonimos but with arguments flipped
justGonimos :: forall state action eff ps
               . ReportErrorAction action => Props ps -> Array (Gonimo eff action)
               -> state -> EffModel eff state action
justGonimos props = flip $ onlyGonimos props

-- | Like `justGonimos` but for a single effect
justGonimo :: forall state action eff ps
               . ReportErrorAction action => Props ps -> Gonimo eff action
               -> state -> EffModel eff state action
justGonimo props eff = justGonimos props [eff]

-- | Convert an our EffModel using update function to one usable for Pux.Config
toPux :: forall state action eff. (action -> state -> EffModel eff state action)
         -> action -> state -> EffModelImpl state action eff
toPux ours action state = runEffModel $ ours action state

foreign import differentObject :: forall a b. a -> b -> Boolean

-- | Gonimo specific Pux helpers and replacements for defaults.

module Gonimo.Pux where

import Prelude
import Gonimo.Client.Types as Gonimo
import Control.Alternative (empty, class Alternative)
import Control.Monad.Aff (Aff)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (class MonadIO, liftIO)
import Control.Monad.Maybe.Trans (runMaybeT, MaybeT(MaybeT))
import Control.Monad.Reader.Class (local, ask, class MonadReader)
import Control.Monad.Reader.Trans (runReaderT, ReaderT(ReaderT))
import Control.Monad.State (State)
import Control.Monad.State.Class (modify, put, get, state, class MonadState)
import Control.Monad.State.Trans (runStateT, StateT(StateT))
import Control.Monad.Trans (lift, class MonadTrans)
import Data.Bifunctor (bimap, class Bifunctor)
import Data.Identity (runIdentity)
import Data.Lens (SetterP, APrismP, (.=), prism, (^?), PrismP, (.~), (^.), LensP)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (GonimoEff, Gonimo, Settings, class ReportErrorAction)
import Partial.Unsafe (unsafeCrashWith)
import Gonimo.Util (runIOToSomeAff)

-- First this was a record but records containing prisms is something psc does not seem to like.
-- | A helper data structure for transforming child components to parent components:
data ChildData parentState childState childProps =
  ChildData (PrismP parentState childState) childProps

makeChildData :: forall parentState childState childProps. PrismP parentState childState -> childProps -> (ChildData parentState childState childProps)
makeChildData fromToParent props = ChildData fromToParent props

childDataFromToParent :: forall parentState childState childProps.
                         ChildData parentState childState childProps
                         -> PrismP parentState childState
childDataFromToParent (ChildData fromToParent _) = fromToParent

childDataProps :: forall parentState childState childProps.
                         ChildData parentState childState childProps
                         -> childProps
childDataProps (ChildData _ props) = props

-- | Create ChildData from a parent component:
type ToChild parentProps parentState childProps childState m =
  (MonadReader parentProps m, MonadState parentState m)
  => m (ChildData parentState childState childProps)

-- | A component is just a Reader monad with react style props and a State monad
-- | with well our component state.
newtype Component props state a = Component (ReaderT props (State state) a)

-- | A component which updates the state somehow and returns zero or more `IO action`.
type Update props state action = Component props state (Array (IO action))

runComponent :: forall props state a. Component props state a -> ReaderT props (State state) a
runComponent (Component m) = m

runComponentFull :: forall props state a. props -> state -> Component props state a -> Tuple a state
runComponentFull props state = runIdentity <<< flip runStateT state <<< flip runReaderT props <<< runComponent

-- | Run a child component and transform it to a parent component, updating the
-- | state only if it actually changed.
-- | We return Nothing if the child is currently not present in the parent.
liftChild :: forall childProps childState parentProps parentState m a.
            ( MonadReader parentProps m
            , MonadState parentState m
            )
            => ToChild parentProps parentState childProps childState m
            -> Component childProps childState a
            -> m (Maybe a)
liftChild toChild child = do
  childData <- toChild
  oldParent <- get
  let
    fromToParent = childDataFromToParent childData
    childProps   = childDataProps childData

    runComponentCheck :: childState -> m a
    runComponentCheck oldChild = do
      case runComponentFull childProps oldChild child of
        Tuple a newChild -> do
          when (differentObject newChild oldChild)
            $ fromToParent .= newChild
          pure a
  traverse runComponentCheck (oldParent ^? fromToParent)

-- | Convert a component to an EffModel usable with Pux.
-- | The restriction to of props to Unit for this root component is currently not justified
-- | and can be dropped if necessary. I just have some vague idea for future enhancements where
-- | properties for the root level component could be in the way.
toEffModel :: forall state action eff. state -> Update Unit state action -> EffModelImpl state action eff
toEffModel initState c =
  case runComponentFull unit initState c of
    Tuple effects state -> { state : state
                           , effects : runIOToSomeAff <$> effects
                           }

instance functorComponent :: Functor (Component props state) where
  map f (Component m) = Component $ map f m

instance applyComponent :: Apply (Component props state) where
  apply (Component mf) (Component ma) = Component $ apply mf ma

instance applicativeComponent :: Applicative (Component props state) where
  pure = Component <<< pure

instance bindComponent :: Bind (Component props state) where
  bind (Component ma) mf = Component $ bind ma (runComponent <<< mf)

instance monadComponent :: Monad (Component props state)

instance monadReaderPropsComponent :: MonadReader props (Component props state) where
  ask = Component ask
  --local :: forall a. (r -> r) -> m a -> m a
  local f (Component ma) = Component (local f ma)

instance monadStateStateComponent :: MonadState state (Component props state) where
  -- get = Component <<< MaybeT <<< runMaybeT <<< ReaderT <<< flip runReaderT
  --       <<< StateT $ \ s -> runStateT (pure s) s
  state f = Component $ state f

type EffModelImpl state action eff =
  { state :: state
  , effects :: Array (Aff (GonimoEff eff) action)
  }

newtype EffModel eff state action = EffModel (EffModelImpl state action eff)

runEffModel :: forall state action eff. EffModel eff state action -> EffModelImpl state action eff
runEffModel (EffModel model) = model

instance bifunctorEffModelEff :: Bifunctor (EffModel eff) where
  bimap f g (EffModel model) = EffModel
    { state : f model.state
    , effects : map (map g) model.effects
    }

updateChild :: forall eff parentState childState parentAction childAction props.
            LensP parentState childState
            -> (childAction -> parentAction)
            -> (props -> childAction -> childState -> EffModel eff childState childAction)
            -> props -> childAction -> parentState -> EffModel eff parentState parentAction
updateChild lens mkAction childUpdate props action state =
    bimap smartUpdate mkAction $ childUpdate props action (state ^. lens)
  where
    smartUpdate :: childState -> parentState
    smartUpdate newChild =if differentObject newChild (state ^. lens)
                          then state # lens .~ newChild
                          else  state

updatePrismChild :: forall eff parentState childState parentAction childAction props.
            PrismP parentState childState
            -> (childAction -> parentAction)
            -> (props -> childAction -> childState -> EffModel eff childState childAction)
            -> props -> childAction -> parentState -> Maybe (EffModel eff parentState parentAction)
updatePrismChild prism mkAction childUpdate props action state =
    bimap smartUpdate mkAction <<< childUpdate props action <$> state ^? prism
  where
    smartUpdate :: childState -> parentState
    smartUpdate newChild = case state ^? prism of
                                Nothing -> state
                                Just oldChild -> if differentObject newChild oldChild
                                                    then state # prism .~ newChild
                                                    else state

-- toParent :: forall eff parentState childState parentAction childAction.
--             LensP parentState childState
--             -> (childAction -> parentAction)
--             -> parentState -> EffModel eff childState childAction
--             -> EffModel eff parentState parentAction
-- toParent lens mkAction state = bimap smartUpdate mkAction
--   where
--     smartUpdate :: childState -> parentState
--     smartUpdate newChild = if differentObject newChild (state ^. lens)
--                            then lens .~ newChild $ state
--                            else state

onlyEffects :: forall state action eff
               .  state -> Array (Aff (GonimoEff eff) action)
               -> EffModel eff state action
onlyEffects state effects = EffModel { state : state
                                     , effects : effects
                                     }

-- | Like `onlyEffects` but for a single effect
onlyEffect :: forall state action eff
               . state -> Aff (GonimoEff eff) action
               -> EffModel eff state action
onlyEffect state eff = onlyEffects state [eff]

-- | Like onlyEffects but with arguments flipped
justEffects :: forall state action eff
               .  Array (Aff (GonimoEff eff) action)
               -> state -> EffModel eff state action
justEffects = flip onlyEffects

-- | Like `justEffects` but for a single effect
justEffect :: forall state action eff
               .  Aff (GonimoEff eff) action
               -> state -> EffModel eff state action
justEffect eff = justEffects [eff]

noEffects :: forall state action eff. state -> EffModel eff state action
noEffects state = EffModel { state : state, effects : [] }

type Props ps = { settings :: Settings | ps }

onlyGonimos :: forall state action eff ps
               . ReportErrorAction action => Props ps -> state -> Array (Gonimo eff action)
               -> EffModel eff state action
onlyGonimos props state = onlyEffects state <<< map (Gonimo.toAff props.settings)

-- | Like `onlyGonimos` but for a single effect
onlyGonimo :: forall state action eff ps
               . ReportErrorAction action => Props ps -> state -> Gonimo eff action
               -> EffModel eff state action
onlyGonimo props state eff = onlyGonimos props state [eff]

-- | Like onlyGonimos but with arguments flipped
justGonimos :: forall state action eff ps
               . ReportErrorAction action => Props ps -> Array (Gonimo eff action)
               -> state -> EffModel eff state action
justGonimos props = flip $ onlyGonimos props

-- | Like `justGonimos` but for a single effect
justGonimo :: forall state action eff ps
               . ReportErrorAction action => Props ps -> Gonimo eff action
               -> state -> EffModel eff state action
justGonimo props eff = justGonimos props [eff]

-- | Convert an our EffModel using update function to one usable for Pux.Config
toPux :: forall state action eff. (action -> state -> EffModel eff state action)
         -> action -> state -> EffModelImpl state action eff
toPux ours action state = runEffModel $ ours action state

foreign import differentObject :: forall a b. a -> b -> Boolean


Now LoginAccount is no longer (stupidly) set as the request content.

It was just being ignored.

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


Cleaned up the imports in the test file.


Signed numeric literals test

Signed numeric literals test

module Main where

  p = +0.5
  q = +1
  x = -1
  y = -0.5
  z = 0.5
  w = 1

  main = Debug.Trace.trace "Done"

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


allFiles'

allFiles'

module FileOperations where

import Data.Path
import Data.Array

allFiles :: Path -> [Path]
allFiles root = root : concatMap allFiles (ls root)

allFiles' :: Path -> [Path]
allFiles' file = file : do
  child <- ls file
  allFiles' child


Add power function

Add power function

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 "kmh"     *> pure (kilo meter ./ hour))
  <|> (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

qPow eBase eExp = do
  base <- eBase
  exp <- eExp
  expNumber <- exp `asValueIn` unity
  pure $ base `pow` expNumber

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 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" }


Made some changes to how status codes are handled.

Now status codes are returned in the response, and we no longer fail if we
get a success code that we were not expecting.


Improved 4.17.1

Improved 4.17.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/'


Now create/login no longer care which success error code is returned.


Minor style tweak

Minor style tweak

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Identity (runIdentity)
import Data.Lens (lens, Lens, (.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.DbEntities (Family(Family), Device(Device))
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ {url : "stun:stun.l.google.com:19302"} ] })
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeStream
  CloseConnection                    -> handleCloseConnection
  AcceptMessage message              -> handleAcceptMessage message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  sendMessage <- getSendMessage
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else sendMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSendStartStreaming :: forall ps. ComponentType (Props ps) State Action
handleSendStartStreaming = do
  sendMessage <- getSendMessage
  pure [ sendMessage Message.StartStreaming ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            sendMessage $ Message.SessionDescriptionOffer offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  sendMessage <- getSendMessage
  pure [ sendMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
            pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleAcceptMessage msg = do
  state <- get
  sendMessage <- getSendMessage
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescriptionOffer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              answer <- liftAff $ createAnswer state.rtcConnection
              liftAff $ setLocalDescription answer state.rtcConnection
              sendMessage $ Message.SessionDescriptionAnswer answer
           ]
    Message.SessionDescriptionAnswer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
           ]
    Message.IceCandidate candidate ->
      pure [ do
               let test = runMaybeIceCandidate candidate
               case test of
                 Nothing -> pure unit -- let's see whether this helps
                 Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
               pure Nop
           ]
    Message.CloseConnection -> closeStream

closeStream :: forall ps. ComponentType (Props ps) State Action
closeStream = do
  state <- get
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeStream
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

view :: State -> Html Action
view state = viewVideo state

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId
                      doDecode
    doDecode :: Maybe (Maybe String) -> Action
    doDecode = maybe Nop AcceptMessage <<< (\mv -> decodeFromString =<< join mv)
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret

module Gonimo.UI.Socket.Channel where

import Prelude
import Data.Array as Arr
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.RTC as RTC
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (get)
import Data.Identity (runIdentity)
import Data.Lens (lens, Lens, (.=))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.DbEntities (Family(Family), Device(Device))
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (Action, Action(..), State, Props)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (coerceEffects)
import Gonimo.WebAPI (putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.RTC (MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, RTCPeerConnection, Ice, newRTCPeerConnection)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ {url : "stun:stun.l.google.com:19302"} ] })
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    liftEff $ MediaStream.clone origStream
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isJust stream
          }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeStream
  CloseConnection                    -> handleCloseConnection
  AcceptMessage message              -> handleAcceptMessage message
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  sendMessage <- getSendMessage
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else sendMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSendStartStreaming :: forall ps. ComponentType (Props ps) State Action
handleSendStartStreaming = do
  sendMessage <- getSendMessage
  pure [ sendMessage Message.StartStreaming ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  sendMessage <- getSendMessage
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            sendMessage $ Message.SessionDescriptionOffer offer
            pure Nop
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  sendMessage <- getSendMessage
  pure [ sendMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
            pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
       ]

getSendMessage :: forall ps. Component (Props ps) State (Message -> IO Action)
getSendMessage = do
  let sendString = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  pure $ toIO props.settings <<< ( \msg ->  do
    let strMsg = encodeToString msg
    sendString strMsg familyId' fromDevice' toDevice' channelId'
    pure Nop)

handleAcceptMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleAcceptMessage msg = do
  state <- get
  sendMessage <- getSendMessage
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescriptionOffer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              answer <- liftAff $ createAnswer state.rtcConnection
              liftAff $ setLocalDescription answer state.rtcConnection
              sendMessage $ Message.SessionDescriptionAnswer answer
           ]
    Message.SessionDescriptionAnswer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
           ]
    Message.IceCandidate candidate ->
      pure [ do
               let test = runMaybeIceCandidate candidate
               case test of
                 Nothing -> pure unit -- let's see whether this helps
                 Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
               pure Nop
           ]
    Message.CloseConnection -> closeStream

closeStream :: forall ps. ComponentType (Props ps) State Action
closeStream = do
  state <- get
  pure $ fromMaybe [] $ do
    stream <- state.mediaStream
    pure [ liftEff $ do
              stopStream stream
              pure Nop
         ]

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  sendMessage <- getSendMessage
  closeActions <- closeStream
  pure $ closeActions <> [ sendMessage Message.CloseConnection ]

view :: State -> Html Action
view state = viewVideo state

viewVideo :: State -> Html Action
viewVideo state =
  H.div [ A.className "videoContainer" ]
  [ case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

  ]

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId
                      doDecode
    doDecode :: Maybe (Maybe String) -> Action
    doDecode = maybe Nop AcceptMessage <<< (\mv -> decodeFromString =<< join mv)
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret


Add options for setTextInBufferRange

Add options for setTextInBufferRange

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


Port Language.PureScript.Errors

Port Language.PureScript.Errors

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Error
-- Copyright   :  (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module Language.PureScript.Errors where

import Prelude.Unsafe (unsafeIndex)
import Data.Array
import qualified Data.Array.Unsafe as Unsafe
import Data.String (joinWith)
import Data.Maybe
import Data.Monoid
import Data.Either
import Data.Monoid.Last
import Data.Foldable (mconcat)

import Control.Monad.Error
import Control.Monad.Error.Class

import Language.PureScript.Declarations
{- import Language.PureScript.Pretty -}
import Language.PureScript.Types

-- |
-- Type for sources of type checking errors
--
data ErrorSource
  -- |
  -- An error which originated at a Value
  --
  = ValueError Value
  -- |
  -- An error which originated at a Type
  --
  | TypeError Type

instance showErrorSource :: Show ErrorSource where
  show (ValueError v) = "ValueError (" ++ show v ++ ")"
  show (TypeError t) = "TypeError (" ++ show t ++ ")"

-- |
-- Compilation errors
--
data CompileError = CompileError {
    -- |
    -- Error message
    --
    compileErrorMessage :: String
    -- |
    -- The value where the error occurred
    --
  , compileErrorValue :: Maybe ErrorSource
    -- |
    -- Optional source position information
    --
  , compileErrorPosition :: Maybe SourcePos
  }

mkCompileError :: String -> Maybe ErrorSource -> Maybe SourcePos -> CompileError
mkCompileError compileErrorMessage compileErrorValue compileErrorPosition =
  CompileError { compileErrorMessage: compileErrorMessage
	             , compileErrorValue: compileErrorValue
							 , compileErrorPosition: compileErrorPosition
							 }

instance showCompileError :: Show CompileError where
  show (CompileError o) = "CompileError {" ++
    "compileErrorMessage: " ++  show o.compileErrorMessage ++
    "compileErrorValue: " ++    show o.compileErrorValue ++
    "compileErrorPosition: " ++ show o.compileErrorPosition ++
	  "}"

-- |
-- A stack trace for an error
--
data ErrorStack = ErrorStack [CompileError]

runErrorStack :: ErrorStack -> [CompileError]
runErrorStack (ErrorStack es) = es

instance showErrorStack :: Show ErrorStack where
  show (ErrorStack es) = "ErrorStack (" ++ show es ++ ")"

instance semigroupErrorStack :: Semigroup ErrorStack where
  (<>) (ErrorStack es1) (ErrorStack es2) = ErrorStack (es1 <> es2)

instance monoidErrorStack :: Monoid ErrorStack where
  mempty = ErrorStack []

instance errorErrorStack :: Error ErrorStack where
  strMsg s = ErrorStack [mkCompileError s Nothing Nothing]
  noMsg = ErrorStack []

prettyPrintErrorStack :: Boolean -> ErrorStack -> String
prettyPrintErrorStack printFullStack (ErrorStack es) =
  case mconcat $ map (\(CompileError o) -> Last o.compileErrorPosition) es of
    Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
    _ -> prettyPrintErrorStack'
  where

    prettyPrintErrorStack' :: String
    prettyPrintErrorStack' =
		  if printFullStack
	    then
		  	joinWith "\n" (map showError (filter isErrorNonEmpty es))
      else
		  	let
          es' = filter isErrorNonEmpty es
        in case length es' of
          1 -> showError (Unsafe.head es')
          _ -> showError (Unsafe.head es') ++ "\n" ++ showError (unsafeLast es')

-- TODO: move this to Data.Array.Unsafe
unsafeLast :: forall a. [a] -> a
unsafeLast xs = unsafeIndex xs (length xs - 1)

stringifyErrorStack :: forall a. Boolean -> Either ErrorStack a -> Either String a
stringifyErrorStack printFullStack = either (Left <<< prettyPrintErrorStack printFullStack) Right

isErrorNonEmpty :: CompileError -> Boolean
isErrorNonEmpty (CompileError { compileErrorMessage = "" }) = false
isErrorNonEmpty _ = true

showError :: CompileError -> String
showError (CompileError { compileErrorMessage = msg, compileErrorValue = Nothing }) = msg
showError (CompileError { compileErrorMessage = msg, compileErrorValue = Just (ValueError val) }) = "Error in value " ++ {- prettyPrintValue -} show val ++ ":\n" ++ msg
showError (CompileError { compileErrorMessage = msg, compileErrorValue = Just (TypeError ty) }) = "Error in type " ++ {- prettyPrintType -} show ty ++ ":\n" ++ msg

mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
mkErrorStack msg t = ErrorStack [mkCompileError msg t Nothing]

positionError :: SourcePos -> ErrorStack
positionError pos = ErrorStack [mkCompileError "" Nothing (Just pos)]

-- |
-- Rethrow an error with a more detailed error message in the case of failure
--
rethrow :: forall e m a. (MonadError e m) => (e -> e) -> m a -> m a
rethrow f = flip catchError $ \e -> throwError (f e)

-- |
-- Rethrow an error with source position information
--
rethrowWithPosition :: forall m a. (MonadError ErrorStack m) => SourcePos -> m a -> m a
rethrowWithPosition pos = rethrow ((<>) (positionError pos))

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


5.9.2