Generalize `unions`

Generalize `unions`

-- | 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
  , toList
  , fromList
  , fromListWith
  , delete
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  ) where

import Prelude

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Delete a key and its corresponding value from a map
delete :: forall k v. (Ord k) => k -> Map k v -> Map k v
delete = down Nil
  where
  down :: forall k v. (Ord k) => 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 :: forall k v. (Ord k) => 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))

  maxNode :: forall k v. (Ord k) => 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

  removeMaxNode :: forall k v. (Ord k) => 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

-- | 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 a map to an array 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 an array of key/value pairs
fromList :: forall k v. (Ord k) => List (Tuple k v) -> Map k v
fromList = foldl (\m (Tuple k v) -> insert k v m) empty

-- | Create a map from an array 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 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

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

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

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

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

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

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

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

import Prelude

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Delete a key and its corresponding value from a map
delete :: forall k v. (Ord k) => k -> Map k v -> Map k v
delete = down Nil
  where
  down :: forall k v. (Ord k) => 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 :: forall k v. (Ord k) => 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))

  maxNode :: forall k v. (Ord k) => 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

  removeMaxNode :: forall k v. (Ord k) => 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

-- | 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 a map to an array 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 an array of key/value pairs
fromList :: forall k v. (Ord k) => List (Tuple k v) -> Map k v
fromList = foldl (\m (Tuple k v) -> insert k v m) empty

-- | Create a map from an array 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 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

-- | Get an array 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 an array 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. (Ord k) => List (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


initial WIP Ajax module

initial WIP Ajax module

module Data.DOM.Simple.Ajax where

import Control.Monad.Eff
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events

foreign import data XMLHttpRequest :: *

foreign import makeXMLHttpRequest
  "function makeXMLHttpRequest() {  \
  \  return function() {            \
  \    return new XMLHttpRequest(); \
  \  }                              \
  \}" :: forall eff. (Eff (dom :: DOM | eff) XMLHttpRequest)

foreign import open
  "function open(method) {                \
  \  return function(url) {               \
  \    return function (obj) {            \
  \      return function () {             \
  \         obj.open(method, url);        \
  \      };                               \
  \    };                                 \
  \  };                                   \
  \}" :: forall eff. XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)

foreign import send
  "function send(obj) {     \
  \  return function () {   \
  \    obj.send();          \
  \  };                     \
  \}" :: forall eff. XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)

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


rev imports

rev imports

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


Changed cursor style on menu items

Changed cursor style on menu items

-- TODO: Encapsulation between Loaded and Socket is very very weak! Some parts are here, some parts are there- this should be fixed!
-- | Loaded application ui logic
module Gonimo.UI.Loaded where

import Gonimo.UI.Html
import Data.Array as Arr
import Data.List as List
import Data.Map as Map
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Router as Router
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Error as Error
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Socket as SocketC
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Lenses as SocketC
import Gonimo.UI.Socket.Types as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Gonimo.WebAPI.Subscriber as Sub
import Pux.Html as H
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Aria as A
import Pux.Html.Attributes.Bootstrap as A
import Pux.Html.Events as E
import Servant.PureScript.Affjax as Affjax
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Error.Class (throwError, catchError)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Class (class MonadReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify, put)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Array (fromFoldable, concat, catMaybes, head)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Right, Left))
import Data.Foldable (foldl)
import Data.Generic (class Generic)
import Data.Generic (gShow)
import Data.Lens (_Just, (.=), to, (^.), (^?))
import Data.Map (Map)
import Data.Maybe (fromMaybe, isNothing, maybe, Maybe(..))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Semigroup (append)
import Data.String (takeWhile)
import Data.Traversable (traverse)
import Data.Tuple (uncurry, fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Types (toIO, Settings, GonimoError(AjaxError, RegisterSessionFailed), class ReportErrorAction, Gonimo)
import Gonimo.Pux (noEffects, Component, toParent, runGonimo, liftChild, ComponentType, makeChildData, ToChild, onlyModify, Update, wrapAction)
import Gonimo.Server.Db.Entities (Device(Device), Family(Family))
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Server.Error (ServerError(InvalidAuthToken))
import Gonimo.Server.Types (DeviceType(Baby, NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (dateToString, Key(Key), Secret(Secret))
import Gonimo.UI.Error (handleError, viewError, class ErrorAction, UserError(NoError, DeviceInvalid))
import Gonimo.UI.Loaded.Central (getCentrals)
import Gonimo.UI.Loaded.Types (mkInviteProps', CentralReq(..), mkInviteProps, mkSettings, mkProps, central, familyIds, authData, currentFamily, socketS, overviewS, Props, acceptS, inviteS, State, Action(..), Central(..), InviteProps)
import Gonimo.UI.Socket.Lenses (sessionId)
import Gonimo.Util (userShow, toString, fromString)
import Gonimo.WebAPI (postSessionByFamilyIdByDeviceId, postInvitationsByFamilyId, postFamilies, getFamiliesByFamilyId, postFunnyName, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (DeviceInfo(DeviceInfo), AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (text, small, script, li, i, a, nav, h3, h2, td, tbody, th, tr, thead, table, ul, p, button, input, h1, span, Html, img, div)
import Pux.Html.Attributes (offset, letterSpacing)
import Pux.Html.Events (FormEvent, FocusEvent)
import Pux.Router (navigateTo)
import Servant.PureScript.Affjax (ErrorDescription(ConnectionError), errorToString, AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber)
import Servant.Subscriber.Connection (Notification(WebSocketOpened, HttpRequestFailed, ParseError, WebSocketClosed, WebSocketError))
import Servant.Subscriber.Internal (doDecode, coerceEffects)
import Servant.Subscriber.Request (HttpRequest(HttpRequest))
import Servant.Subscriber.Response (HttpResponse(HttpResponse))
import Servant.Subscriber.Subscriptions (Subscriptions)
import Servant.Subscriber.Util (toUserType)
import Signal (constant, Signal)
import Prelude hiding (div)

update :: Update Unit State Action
update (SetState state)                        = put state *> pure []
update (ReportError err)                       = handleError err
update (InviteA _ InviteC.GoToOverview)        = handleRequestCentral ReqCentralOverview
update (InviteA _ InviteC.GoToBabyStation)     = handleRequestCentral ReqCentralBaby
update (InviteA _ (InviteC.ReportError err))   = handleError err
update (InviteA mProps action)                 = updateInvite mProps action
update (AcceptA (AcceptC.ReportError err))     = handleError err
update (AcceptA action)                        = updateAccept action
update (SocketA a@(SocketC.ReportError err))   = append <$> handleError err <*> updateSocket a
update (SocketA action)                        = updateSocket action
update (OverviewA (OverviewC.SocketA socketA)) = updateSocket socketA
update (OverviewA OverviewC.GoToInviteView)    = handleRequestCentral ReqCentralInvite
update (OverviewA action)                      = updateOverview action
update (SetFamilyIds ids)                      = handleSetFamilyIds ids
update (UpdateFamily familyId' family')        = onlyModify $ \state ->  state { families = Map.insert familyId' family' state.families }
update (RequestCentral c)                      = handleRequestCentral c
update (SetCentral c)                          = handleSetCentral c
update (SetOnlineDevices devices)              = onlyModify $ _ { onlineDevices = devices }
update (SetDeviceInfos devices)                = onlyModify $ _ { deviceInfos = devices }
update (SetURL url)                            = handleSetURL url
update (HandleSubscriber msg)                  = handleSubscriber msg
update ResetDevice                             = handleResetDevice
update ClearError                              = handleClearError
update Nop                                     = noEffects

toInvite :: InviteProps -> ToChild Unit State InviteProps InviteC.State
toInvite props = pure $ makeChildData inviteS props

toAccept :: ToChild Unit State Props AcceptC.State
toAccept = do
  props <- mkProps <$> get
  pure $ makeChildData acceptS props

toOverview :: ToChild Unit State Props OverviewC.State
toOverview = do
  props <- mkProps <$> get
  pure $ makeChildData overviewS props

toSocket :: ToChild Unit State Props SocketC.State
toSocket = do
  props <- mkProps <$> get
  pure $ makeChildData socketS props

updateInvite :: Maybe InviteProps -> InviteC.Action -> ComponentType Unit State Action
updateInvite mProps iAction = do
  state <- get :: Component Unit State State
  let props = mkInviteProps state <|> mProps -- State props have higher priority!
  case props of
    Nothing -> pure $
              [ toIO (mkSettings $ state^.authData) $ do
                    name <- postFunnyName
                    fid' <- postFamilies name
                    family' <- getFamiliesByFamilyId fid'
                    let newProps = mkInviteProps' fid' family' state
                    pure $ InviteA (Just newProps) iAction
              ]
    Just rProps ->
      toParent [] (InviteA Nothing) <<< liftChild (toInvite rProps) <<< InviteC.update $ iAction

updateAccept :: AcceptC.Action -> ComponentType Unit State Action
updateAccept = toParent [] AcceptA <<< liftChild toAccept <<< AcceptC.update

updateOverview :: OverviewC.Action -> ComponentType Unit State Action
updateOverview = toParent [] OverviewA <<< liftChild toOverview <<< OverviewC.update

updateSocket :: SocketC.Action -> ComponentType Unit State Action
updateSocket action = do
  case action of
    SocketC.SetAuthData _ -> handleSetAuthData
    _ -> pure unit
  toParent [] SocketA <<< liftChild toSocket $ SocketC.update action

inviteEffect :: forall m. Monad m => Secret -> m Action
inviteEffect = pure <<< AcceptA <<< AcceptC.LoadInvitation

handleSubscriber :: Notification -> ComponentType Unit State Action
handleSubscriber notification = do
  append <$> Error.handleSubscriber notification
         <*> updateSocket (SocketC.HandleSubscriber notification)

handleResetDevice :: ComponentType Unit State Action
handleResetDevice = do
  props <- mkProps <$> get :: Component Unit State State
  pure $ [ toIO props.settings $ do
              liftEff $ localStorage.removeItem Key.authData
              SocketA <<< SocketC.SetAuthData <$> getAuthData
         ]

handleRequestCentral :: CentralReq -> ComponentType Unit State Action
handleRequestCentral c = do
  state <- get
  r <- case c of
    ReqCentralInvite   -> do
      let invProps = mkInviteProps state
      case invProps of
        Nothing    -> pure
                   [ toIO (mkSettings $ state^.authData) $ do
                        name <- postFunnyName
                        fid' <- postFamilies name
                        family' <- getFamiliesByFamilyId fid'
                        let newProps = mkInviteProps' fid' family' state
                        invData <- postInvitationsByFamilyId fid'
                        pure <<< SetCentral <<< CentralInvite $ (InviteC.init invData newProps)
                   ]
        Just props -> pure
                      [ toIO (mkSettings $ state^.authData) $ do
                           invData <- postInvitationsByFamilyId props.rFamilyId
                           pure <<< SetCentral $ CentralInvite (InviteC.init invData props)
                      ]
    ReqCentralOverview -> handleSetCentral CentralOverview
    ReqCentralBaby     -> do
                          handleSetCentral CentralBaby
                          pure [ pure $ SocketA SocketC.GetUserMedia ]
  case Tuple state.central c of
    Tuple CentralBaby ReqCentralBaby -> pure r
    Tuple CentralBaby _              -> pure $ [ pure $ SocketA SocketC.StopUserMedia ] <> r
    Tuple _ _                        -> pure r

handleSetCentral :: Central -> ComponentType Unit State Action
handleSetCentral central' = central .= central' *> noEffects

handleSetAuthData :: Component Unit State Unit
handleSetAuthData = modify $ \state -> state
                                  {
                                   userError = case state.userError of
                                      DeviceInvalid -> NoError
                                      _ -> state.userError
                                  }
handleSetFamilyIds :: Array (Key Family) -> ComponentType Unit State Action
handleSetFamilyIds ids = do
  familyIds .= ids
  state <- get :: Component Unit State State
  if isNothing state.socketS.currentFamily
    then pure $ fromFoldable $ pure <<< SocketA <<< SocketC.SwitchFamily <$> Arr.head ids
    else noEffects

handleSetURL :: String -> ComponentType Unit State Action
handleSetURL url = do
  let
    route = Router.match url
    withoutQuery = takeWhile (_ /= '?') url
  case route of
    Router.Home -> onlyModify $ _ { url = url }
    Router.AcceptInvitation s -> do
      modify $ _ { url = withoutQuery
                 }
      actions <- handleSetCentral $ CentralAccept (AcceptC.init)
      pure $ [ do
               liftEff $ navigateTo withoutQuery
               inviteEffect s
             ] <> actions

handleClearError :: ComponentType Unit State Action
handleClearError = do
  state <- (get :: Component Unit State State)
  let
    newCentral = case state.central of
      CentralAccept (Just _) -> state.central
      _                     -> CentralOverview

  onlyModify $ _ { userError = NoError
                 , central = newCentral
                 }

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

view :: State -> Html Action
view state =
  let
    numDevices = Arr.length state.onlineDevices
  in
    case state.userError of
      NoError ->
        div []
        [ viewHeader state
        , viewCentral state
        , div []
          [ h3 [] [ text $ show numDevices <> " Device(s) currently online:" ]
          , div [] [ viewOnlineDevices state ]
          ]
        ]
      err -> viewError state

viewHeader :: State -> Html Action
viewHeader state =
      nav [ A.className "navbar navbar-default" ]
      [ div [ A.className "container"]
    -- Brand and toggle get grouped for better mobile display --
          [ div [ A.className "navbar-header"]
            [ burgerButton
            , a [ A.className "navbar-brand"]
              [ img [ A.alt "gonimo"
                    , A.src "./pix/gonimo-brand-01.svg"
                    , A.width "45px"
                    , A.height "45px"
                    , A.style [Tuple "padding" "5px 7.5px 0px 7.5px"]
                    ] []
              ]
            ]

    -- Collect the nav links, forms, and other content for toggling --
          , div [ A.className "collapse navbar-collapse"
                , A.id_ "navbarmenu"
                , A.style [Tuple "width" "100%"]
                , A.dataToggle "collapse"
                , A.dataTarget ".navbar-collapse.in"
                ]
            [ ul [ A.className "nav navbar-nav"] $ (viewCentralItem <$> getCentrals state) <>
              [ viewFamilyChooser state
        --      , viewUserSettings
              ]
            ]
          ]
        ]

  where
    burgerButton :: Html Action
    burgerButton = button [ A.type_ "button"
                          , A.className "navbar-toggle collapsed"
                          , A.dataToggle "collapse"
                          , A.dataTarget "#navbarmenu"
                          , A.ariaExpanded "false"
                          ]
                   [ span [A.className "sr-only"] [text "Toggle navigation"]
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   ]
    viewCentralItem :: Tuple Boolean CentralReq -> Html Action
    viewCentralItem (Tuple active item) =
      li (if active then [ A.className "active" ] else []
          <>    [ A.dataToggle "collapse"
                , A.dataTarget ".navbar-collapse.in"]
         )
         [ a [ E.onClick <<< const $ RequestCentral item
             , A.type_ "button", A.role "button"]
           [ text $ userShow item ]
         ]

viewUserSettings :: Html Action
viewUserSettings =
  li [A.className "dropdown navbar-right"]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-user"] []
    , text " "
    , text "Max Mustermann"
    , text " "
    , span [A.className "caret"] []
    ]
  , ul [A.className "dropdown-menu", A.style [Tuple "minWidth" "180px"]]
    [ li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [text "Change user settings (WIP)"]]
    , li [A.className "disabled"] [a [] [text " User settings "
                  ,i [A.className "fa fa-fw fa-cog pull-right"] []]]
    , li [A.className "disabled"] [ a [] [ text "Change password "
                   , i [A.className "fa fa-fw fa-lock pull-right" ][]
                   ]]
    , li [A.className "divider", A.role "separator"] []
    , li [A.className "disabled"] [a [] [ text "Log-Out "
                  , i [A.className "fa fa-fw fa-sign-out pull-right"] []
                  ]]
    ]
  ]

viewCentral :: State -> Html Action
viewCentral state =
  let
    props = mkProps state
    invProps = mkInviteProps state
  in
   case state.central of
    CentralInvite s -> case invProps of
      Nothing -> viewLoading "Loading, please wait ..."
      Just invProps' -> map (InviteA Nothing) $ InviteC.view invProps' s
    CentralAccept s -> map AcceptA $ AcceptC.view s
    CentralOverview     -> map OverviewA   $ OverviewC.view props state.overviewS
    CentralBaby     -> map SocketA   $ SocketC.view props state.socketS

viewOnlineDevices :: State -> Html Action
viewOnlineDevices state = table [ A.className "table table-striped"]
                          [ head
                          , body
                          ]
  where
    head = thead []
           [ tr []
             [
               -- th [ A.className "centered"] [ text "Online" ]
             -- , th [ A.className "centered"] [ text "Type" ]
               th [] [ text "Name" ]
             , th [] [ text "Last Seen"]
             -- , th [] []
             -- , th [] []
             -- , th [] []
             ]
           ]
    body = tbody []
           <<< Arr.mapMaybe viewOnlineDevice
           $ map fst state.onlineDevices
    viewOnlineDevice deviceId = do
        (DeviceInfo info) <- Tuple.lookup deviceId state.deviceInfos
        let name = info.deviceInfoName
        let lastAccessed = dateToString info.deviceInfoLastAccessed
        pure $ tr []
               [
                 -- td [A.className "centered"] [ i [ A.className ("fa fa-" <> "circle-o") -- "check-circle"
                 --       , A.dataToggle "tooltip"
                 --       , A.dataPlacement "right"
                 --       , A.title "offline" ] []]
                 --       --, A.title "online" ] []]
               -- , td [A.className "centered"]
               --     [ i [ A.className ("fa fa-fw fa-" <> "mobile")
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "edit device name" ] []
               --         ]
                 td [] [ text name ]
               , td [] [ text lastAccessed ]
               -- , td [] [ i [ A.className "fa fa-fw fa-pencil"
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "edit device name" ] []
               --         ]
               -- , td [] [ i [ A.className "fa fa-fw fa-trash"
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "delete device from family" ] []]
               --
               ]

viewFamilyChooser :: State -> Html Action
viewFamilyChooser state =
  li [ A.className "dropdown"
     , A.dataToggle "collapse"
     ]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-users"] []
    , text " "
    , text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)
    {--, span [] [text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)]--}
    , text " "
    , span [A.className "caret"] [] ]
    , H.ul [A.className "dropdown-menu"] $
        [li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [text "Change family to"]]]
        <> (fromFoldable <<< map (uncurry (viewFamily state.socketS.currentFamily))
                         <<< Map.toList $ state.families)
  ]
  where
    doSwitchFamily :: Key Family -> Action
    doSwitchFamily = SocketA <<< SocketC.SwitchFamily

    viewFamily :: Maybe (Key Family) -> Key Family -> Family -> Html Action
    viewFamily currentFamilyId familyId (Family family) =
        li [] [a [E.onClick $ const $ doSwitchFamily familyId ] $
                 [text family.familyName] <> if Just familyId == currentFamilyId
                                                then [text " ✔"]
                                                else []
              ]

--------------------------------------------------------------------------------
getSubscriptions :: State -> Subscriptions Action
getSubscriptions state =
  let
    familyId = state^?currentFamily
    sessionId' = state^.socketS<<<sessionId
    --subscribeGetFamily :: forall m. MonadReader Settings m => Key Family -> m (Subscriptions Action)
    subscribeGetFamily familyId' =
      Sub.getFamiliesByFamilyId (maybe Nop (UpdateFamily familyId')) familyId'

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader (mkSettings $ state^.authData)) <<< concat $
      [ [ Sub.getAccountsByAccountIdFamilies (maybe Nop SetFamilyIds)
                                          (runAuthData $ state^.authData).accountId
        ]
      , fromFoldable $ do
           _ <- sessionId' -- Avoid error message `FamilyNotOnline` when not yet ready.
           Sub.getSessionByFamilyId (maybe Nop SetOnlineDevices) <$> familyId
      , fromFoldable $
        Sub.getFamiliesByFamilyIdDeviceInfos (maybe Nop SetDeviceInfos) <$> familyId
      , map subscribeGetFamily state.familyIds
      ]
  in
   case state.userError of
     NoError -> foldl append mempty subArray <> map SocketA (SocketC.getSubscriptions (mkProps state) state.socketS)
     _       -> mempty

getPongRequest :: State -> Maybe HttpRequest
getPongRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    onlineStatus' = state ^. socketS <<< to SocketC.toDeviceType
    sessionId'    = state ^. socketS <<< to _.sessionId
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.putSessionByFamilyIdByDeviceIdBySessionId onlineStatus'
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _       -> Nothing

getCloseRequest :: State -> Maybe HttpRequest
getCloseRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    familyId = state^?currentFamily
    sessionId' = state ^. socketS <<< to _.sessionId
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.deleteSessionByFamilyIdByDeviceIdBySessionId
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _ -> Nothing

-- | Retrieve AuthData from local storage or if not present get new one from server
getAuthData :: Gonimo AuthData
getAuthData = do
  md <- liftEff $ localStorage.getItem Key.authData
  Gonimo.log $ "Got authdata from local storage: " <> gShow md
  case md of
    Nothing -> do
      auth <- postAccounts
      Gonimo.log $ "Got Nothing - called postAccounts and got: " <> gShow auth
      Gonimo.log $ "Calling setItem with : " <> gShow Key.authData
      liftEff $ localStorage.setItem Key.authData auth
      pure auth
    Just d  -> pure d

-- TODO: Encapsulation between Loaded and Socket is very very weak! Some parts are here, some parts are there- this should be fixed!
-- | Loaded application ui logic
module Gonimo.UI.Loaded where

import Gonimo.UI.Html
import Data.Array as Arr
import Data.List as List
import Data.Map as Map
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Router as Router
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Error as Error
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Socket as SocketC
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Lenses as SocketC
import Gonimo.UI.Socket.Types as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Gonimo.WebAPI.Subscriber as Sub
import Pux.Html as H
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Aria as A
import Pux.Html.Attributes.Bootstrap as A
import Pux.Html.Events as E
import Servant.PureScript.Affjax as Affjax
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Error.Class (throwError, catchError)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Class (class MonadReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify, put)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Array (fromFoldable, concat, catMaybes, head)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Right, Left))
import Data.Foldable (foldl)
import Data.Generic (class Generic)
import Data.Generic (gShow)
import Data.Lens (_Just, (.=), to, (^.), (^?))
import Data.Map (Map)
import Data.Maybe (fromMaybe, isNothing, maybe, Maybe(..))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Semigroup (append)
import Data.String (takeWhile)
import Data.Traversable (traverse)
import Data.Tuple (uncurry, fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Types (toIO, Settings, GonimoError(AjaxError, RegisterSessionFailed), class ReportErrorAction, Gonimo)
import Gonimo.Pux (noEffects, Component, toParent, runGonimo, liftChild, ComponentType, makeChildData, ToChild, onlyModify, Update, wrapAction)
import Gonimo.Server.Db.Entities (Device(Device), Family(Family))
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Server.Error (ServerError(InvalidAuthToken))
import Gonimo.Server.Types (DeviceType(Baby, NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (dateToString, Key(Key), Secret(Secret))
import Gonimo.UI.Error (handleError, viewError, class ErrorAction, UserError(NoError, DeviceInvalid))
import Gonimo.UI.Loaded.Central (getCentrals)
import Gonimo.UI.Loaded.Types (mkInviteProps', CentralReq(..), mkInviteProps, mkSettings, mkProps, central, familyIds, authData, currentFamily, socketS, overviewS, Props, acceptS, inviteS, State, Action(..), Central(..), InviteProps)
import Gonimo.UI.Socket.Lenses (sessionId)
import Gonimo.Util (userShow, toString, fromString)
import Gonimo.WebAPI (postSessionByFamilyIdByDeviceId, postInvitationsByFamilyId, postFamilies, getFamiliesByFamilyId, postFunnyName, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (DeviceInfo(DeviceInfo), AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (text, small, script, li, i, a, nav, h3, h2, td, tbody, th, tr, thead, table, ul, p, button, input, h1, span, Html, img, div)
import Pux.Html.Attributes (offset, letterSpacing)
import Pux.Html.Events (FormEvent, FocusEvent)
import Pux.Router (navigateTo)
import Servant.PureScript.Affjax (ErrorDescription(ConnectionError), errorToString, AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber)
import Servant.Subscriber.Connection (Notification(WebSocketOpened, HttpRequestFailed, ParseError, WebSocketClosed, WebSocketError))
import Servant.Subscriber.Internal (doDecode, coerceEffects)
import Servant.Subscriber.Request (HttpRequest(HttpRequest))
import Servant.Subscriber.Response (HttpResponse(HttpResponse))
import Servant.Subscriber.Subscriptions (Subscriptions)
import Servant.Subscriber.Util (toUserType)
import Signal (constant, Signal)
import Prelude hiding (div)

update :: Update Unit State Action
update (SetState state)                        = put state *> pure []
update (ReportError err)                       = handleError err
update (InviteA _ InviteC.GoToOverview)        = handleRequestCentral ReqCentralOverview
update (InviteA _ InviteC.GoToBabyStation)     = handleRequestCentral ReqCentralBaby
update (InviteA _ (InviteC.ReportError err))   = handleError err
update (InviteA mProps action)                 = updateInvite mProps action
update (AcceptA (AcceptC.ReportError err))     = handleError err
update (AcceptA action)                        = updateAccept action
update (SocketA a@(SocketC.ReportError err))   = append <$> handleError err <*> updateSocket a
update (SocketA action)                        = updateSocket action
update (OverviewA (OverviewC.SocketA socketA)) = updateSocket socketA
update (OverviewA OverviewC.GoToInviteView)    = handleRequestCentral ReqCentralInvite
update (OverviewA action)                      = updateOverview action
update (SetFamilyIds ids)                      = handleSetFamilyIds ids
update (UpdateFamily familyId' family')        = onlyModify $ \state ->  state { families = Map.insert familyId' family' state.families }
update (RequestCentral c)                      = handleRequestCentral c
update (SetCentral c)                          = handleSetCentral c
update (SetOnlineDevices devices)              = onlyModify $ _ { onlineDevices = devices }
update (SetDeviceInfos devices)                = onlyModify $ _ { deviceInfos = devices }
update (SetURL url)                            = handleSetURL url
update (HandleSubscriber msg)                  = handleSubscriber msg
update ResetDevice                             = handleResetDevice
update ClearError                              = handleClearError
update Nop                                     = noEffects

toInvite :: InviteProps -> ToChild Unit State InviteProps InviteC.State
toInvite props = pure $ makeChildData inviteS props

toAccept :: ToChild Unit State Props AcceptC.State
toAccept = do
  props <- mkProps <$> get
  pure $ makeChildData acceptS props

toOverview :: ToChild Unit State Props OverviewC.State
toOverview = do
  props <- mkProps <$> get
  pure $ makeChildData overviewS props

toSocket :: ToChild Unit State Props SocketC.State
toSocket = do
  props <- mkProps <$> get
  pure $ makeChildData socketS props

updateInvite :: Maybe InviteProps -> InviteC.Action -> ComponentType Unit State Action
updateInvite mProps iAction = do
  state <- get :: Component Unit State State
  let props = mkInviteProps state <|> mProps -- State props have higher priority!
  case props of
    Nothing -> pure $
              [ toIO (mkSettings $ state^.authData) $ do
                    name <- postFunnyName
                    fid' <- postFamilies name
                    family' <- getFamiliesByFamilyId fid'
                    let newProps = mkInviteProps' fid' family' state
                    pure $ InviteA (Just newProps) iAction
              ]
    Just rProps ->
      toParent [] (InviteA Nothing) <<< liftChild (toInvite rProps) <<< InviteC.update $ iAction

updateAccept :: AcceptC.Action -> ComponentType Unit State Action
updateAccept = toParent [] AcceptA <<< liftChild toAccept <<< AcceptC.update

updateOverview :: OverviewC.Action -> ComponentType Unit State Action
updateOverview = toParent [] OverviewA <<< liftChild toOverview <<< OverviewC.update

updateSocket :: SocketC.Action -> ComponentType Unit State Action
updateSocket action = do
  case action of
    SocketC.SetAuthData _ -> handleSetAuthData
    _ -> pure unit
  toParent [] SocketA <<< liftChild toSocket $ SocketC.update action

inviteEffect :: forall m. Monad m => Secret -> m Action
inviteEffect = pure <<< AcceptA <<< AcceptC.LoadInvitation

handleSubscriber :: Notification -> ComponentType Unit State Action
handleSubscriber notification = do
  append <$> Error.handleSubscriber notification
         <*> updateSocket (SocketC.HandleSubscriber notification)

handleResetDevice :: ComponentType Unit State Action
handleResetDevice = do
  props <- mkProps <$> get :: Component Unit State State
  pure $ [ toIO props.settings $ do
              liftEff $ localStorage.removeItem Key.authData
              SocketA <<< SocketC.SetAuthData <$> getAuthData
         ]

handleRequestCentral :: CentralReq -> ComponentType Unit State Action
handleRequestCentral c = do
  state <- get
  r <- case c of
    ReqCentralInvite   -> do
      let invProps = mkInviteProps state
      case invProps of
        Nothing    -> pure
                   [ toIO (mkSettings $ state^.authData) $ do
                        name <- postFunnyName
                        fid' <- postFamilies name
                        family' <- getFamiliesByFamilyId fid'
                        let newProps = mkInviteProps' fid' family' state
                        invData <- postInvitationsByFamilyId fid'
                        pure <<< SetCentral <<< CentralInvite $ (InviteC.init invData newProps)
                   ]
        Just props -> pure
                      [ toIO (mkSettings $ state^.authData) $ do
                           invData <- postInvitationsByFamilyId props.rFamilyId
                           pure <<< SetCentral $ CentralInvite (InviteC.init invData props)
                      ]
    ReqCentralOverview -> handleSetCentral CentralOverview
    ReqCentralBaby     -> do
                          handleSetCentral CentralBaby
                          pure [ pure $ SocketA SocketC.GetUserMedia ]
  case Tuple state.central c of
    Tuple CentralBaby ReqCentralBaby -> pure r
    Tuple CentralBaby _              -> pure $ [ pure $ SocketA SocketC.StopUserMedia ] <> r
    Tuple _ _                        -> pure r

handleSetCentral :: Central -> ComponentType Unit State Action
handleSetCentral central' = central .= central' *> noEffects

handleSetAuthData :: Component Unit State Unit
handleSetAuthData = modify $ \state -> state
                                  {
                                   userError = case state.userError of
                                      DeviceInvalid -> NoError
                                      _ -> state.userError
                                  }
handleSetFamilyIds :: Array (Key Family) -> ComponentType Unit State Action
handleSetFamilyIds ids = do
  familyIds .= ids
  state <- get :: Component Unit State State
  if isNothing state.socketS.currentFamily
    then pure $ fromFoldable $ pure <<< SocketA <<< SocketC.SwitchFamily <$> Arr.head ids
    else noEffects

handleSetURL :: String -> ComponentType Unit State Action
handleSetURL url = do
  let
    route = Router.match url
    withoutQuery = takeWhile (_ /= '?') url
  case route of
    Router.Home -> onlyModify $ _ { url = url }
    Router.AcceptInvitation s -> do
      modify $ _ { url = withoutQuery
                 }
      actions <- handleSetCentral $ CentralAccept (AcceptC.init)
      pure $ [ do
               liftEff $ navigateTo withoutQuery
               inviteEffect s
             ] <> actions

handleClearError :: ComponentType Unit State Action
handleClearError = do
  state <- (get :: Component Unit State State)
  let
    newCentral = case state.central of
      CentralAccept (Just _) -> state.central
      _                     -> CentralOverview

  onlyModify $ _ { userError = NoError
                 , central = newCentral
                 }

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

view :: State -> Html Action
view state =
  let
    numDevices = Arr.length state.onlineDevices
  in
    case state.userError of
      NoError ->
        div []
        [ viewHeader state
        , viewCentral state
        , div []
          [ h3 [] [ text $ show numDevices <> " Device(s) currently online:" ]
          , div [] [ viewOnlineDevices state ]
          ]
        ]
      err -> viewError state

viewHeader :: State -> Html Action
viewHeader state =
      nav [ A.className "navbar navbar-default" ]
      [ div [ A.className "container"]
    -- Brand and toggle get grouped for better mobile display --
          [ div [ A.className "navbar-header"]
            [ burgerButton
            , a [ A.className "navbar-brand"]
              [ img [ A.alt "gonimo"
                    , A.src "./pix/gonimo-brand-01.svg"
                    , A.width "45px"
                    , A.height "45px"
                    , A.style [Tuple "padding" "5px 7.5px 0px 7.5px"]
                    ] []
              ]
            ]

    -- Collect the nav links, forms, and other content for toggling --
          , div [ A.className "collapse navbar-collapse"
                , A.id_ "navbarmenu"
                , A.style [Tuple "width" "100%"]
                , A.dataToggle "collapse"
                , A.dataTarget ".navbar-collapse.in"
                ]
            [ ul [ A.className "nav navbar-nav"] $ (viewCentralItem <$> getCentrals state) <>
              [ viewFamilyChooser state
        --      , viewUserSettings
              ]
            ]
          ]
        ]

  where
    burgerButton :: Html Action
    burgerButton = button [ A.type_ "button"
                          , A.className "navbar-toggle collapsed"
                          , A.dataToggle "collapse"
                          , A.dataTarget "#navbarmenu"
                          , A.ariaExpanded "false"
                          ]
                   [ span [A.className "sr-only"] [text "Toggle navigation"]
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   ]
    viewCentralItem :: Tuple Boolean CentralReq -> Html Action
    viewCentralItem (Tuple active item) =
      li (if active then [ A.className "active" ] else []
          <>    [ A.dataToggle "collapse"
                , A.dataTarget ".navbar-collapse.in"]
         )
         [ a [ E.onClick <<< const $ RequestCentral item ]
           [ text $ userShow item ]
         ]

viewUserSettings :: Html Action
viewUserSettings =
  li [A.className "dropdown navbar-right"]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-user"] []
    , text " "
    , text "Max Mustermann"
    , text " "
    , span [A.className "caret"] []
    ]
  , ul [A.className "dropdown-menu", A.style [Tuple "minWidth" "180px"]]
    [ li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [text "Change user settings (WIP)"]]
    , li [A.className "disabled"] [a [] [text " User settings "
                  ,i [A.className "fa fa-fw fa-cog pull-right"] []]]
    , li [A.className "disabled"] [ a [] [ text "Change password "
                   , i [A.className "fa fa-fw fa-lock pull-right" ][]
                   ]]
    , li [A.className "divider", A.role "separator"] []
    , li [A.className "disabled"] [a [] [ text "Log-Out "
                  , i [A.className "fa fa-fw fa-sign-out pull-right"] []
                  ]]
    ]
  ]

viewCentral :: State -> Html Action
viewCentral state =
  let
    props = mkProps state
    invProps = mkInviteProps state
  in
   case state.central of
    CentralInvite s -> case invProps of
      Nothing -> viewLoading "Loading, please wait ..."
      Just invProps' -> map (InviteA Nothing) $ InviteC.view invProps' s
    CentralAccept s -> map AcceptA $ AcceptC.view s
    CentralOverview     -> map OverviewA   $ OverviewC.view props state.overviewS
    CentralBaby     -> map SocketA   $ SocketC.view props state.socketS

viewOnlineDevices :: State -> Html Action
viewOnlineDevices state = table [ A.className "table table-striped"]
                          [ head
                          , body
                          ]
  where
    head = thead []
           [ tr []
             [
               -- th [ A.className "centered"] [ text "Online" ]
             -- , th [ A.className "centered"] [ text "Type" ]
               th [] [ text "Name" ]
             , th [] [ text "Last Seen"]
             -- , th [] []
             -- , th [] []
             -- , th [] []
             ]
           ]
    body = tbody []
           <<< Arr.mapMaybe viewOnlineDevice
           $ map fst state.onlineDevices
    viewOnlineDevice deviceId = do
        (DeviceInfo info) <- Tuple.lookup deviceId state.deviceInfos
        let name = info.deviceInfoName
        let lastAccessed = dateToString info.deviceInfoLastAccessed
        pure $ tr []
               [
                 -- td [A.className "centered"] [ i [ A.className ("fa fa-" <> "circle-o") -- "check-circle"
                 --       , A.dataToggle "tooltip"
                 --       , A.dataPlacement "right"
                 --       , A.title "offline" ] []]
                 --       --, A.title "online" ] []]
               -- , td [A.className "centered"]
               --     [ i [ A.className ("fa fa-fw fa-" <> "mobile")
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "edit device name" ] []
               --         ]
                 td [] [ text name ]
               , td [] [ text lastAccessed ]
               -- , td [] [ i [ A.className "fa fa-fw fa-pencil"
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "edit device name" ] []
               --         ]
               -- , td [] [ i [ A.className "fa fa-fw fa-trash"
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "delete device from family" ] []]
               --
               ]

viewFamilyChooser :: State -> Html Action
viewFamilyChooser state =
  li [ A.className "dropdown"
     , A.dataToggle "collapse"
     ]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-users"] []
    , text " "
    , text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)
    {--, span [] [text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)]--}
    , text " "
    , span [A.className "caret"] [] ]
    , H.ul [A.className "dropdown-menu"] $
        [li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [text "Change family to"]]]
        <> (fromFoldable <<< map (uncurry (viewFamily state.socketS.currentFamily))
                         <<< Map.toList $ state.families)
  ]
  where
    doSwitchFamily :: Key Family -> Action
    doSwitchFamily = SocketA <<< SocketC.SwitchFamily

    viewFamily :: Maybe (Key Family) -> Key Family -> Family -> Html Action
    viewFamily currentFamilyId familyId (Family family) =
        li [] [a [E.onClick $ const $ doSwitchFamily familyId ] $
                 [text family.familyName] <> if Just familyId == currentFamilyId
                                                then [text " ✔"]
                                                else []
              ]

--------------------------------------------------------------------------------
getSubscriptions :: State -> Subscriptions Action
getSubscriptions state =
  let
    familyId = state^?currentFamily
    sessionId' = state^.socketS<<<sessionId
    --subscribeGetFamily :: forall m. MonadReader Settings m => Key Family -> m (Subscriptions Action)
    subscribeGetFamily familyId' =
      Sub.getFamiliesByFamilyId (maybe Nop (UpdateFamily familyId')) familyId'

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader (mkSettings $ state^.authData)) <<< concat $
      [ [ Sub.getAccountsByAccountIdFamilies (maybe Nop SetFamilyIds)
                                          (runAuthData $ state^.authData).accountId
        ]
      , fromFoldable $ do
           _ <- sessionId' -- Avoid error message `FamilyNotOnline` when not yet ready.
           Sub.getSessionByFamilyId (maybe Nop SetOnlineDevices) <$> familyId
      , fromFoldable $
        Sub.getFamiliesByFamilyIdDeviceInfos (maybe Nop SetDeviceInfos) <$> familyId
      , map subscribeGetFamily state.familyIds
      ]
  in
   case state.userError of
     NoError -> foldl append mempty subArray <> map SocketA (SocketC.getSubscriptions (mkProps state) state.socketS)
     _       -> mempty

getPongRequest :: State -> Maybe HttpRequest
getPongRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    onlineStatus' = state ^. socketS <<< to SocketC.toDeviceType
    sessionId'    = state ^. socketS <<< to _.sessionId
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.putSessionByFamilyIdByDeviceIdBySessionId onlineStatus'
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _       -> Nothing

getCloseRequest :: State -> Maybe HttpRequest
getCloseRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    familyId = state^?currentFamily
    sessionId' = state ^. socketS <<< to _.sessionId
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.deleteSessionByFamilyIdByDeviceIdBySessionId
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _ -> Nothing

-- | Retrieve AuthData from local storage or if not present get new one from server
getAuthData :: Gonimo AuthData
getAuthData = do
  md <- liftEff $ localStorage.getItem Key.authData
  Gonimo.log $ "Got authdata from local storage: " <> gShow md
  case md of
    Nothing -> do
      auth <- postAccounts
      Gonimo.log $ "Got Nothing - called postAccounts and got: " <> gShow auth
      Gonimo.log $ "Calling setItem with : " <> gShow Key.authData
      liftEff $ localStorage.setItem Key.authData auth
      pure auth
    Just d  -> pure d


Refactored 4.17.2 so that importing Path's data constructors isn't necessary

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


Minor changes.

Minor changes.

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


re-introduce semantic validation

re-introduce semantic validation

module Ifrit.Semantic
  ( Schema(..)
  , analyze
  , fromJson
  ) where

import Prelude

import Data.Argonaut.Core(foldJson, stringify)
import Data.Argonaut.Decode(class DecodeJson, decodeJson)
import Data.Argonaut.Encode(class EncodeJson, encodeJson)
import Data.Argonaut.Parser(jsonParser)
import Data.Array(head, length)
import Data.Either(Either(..))
import Data.List as List
import Data.Maybe(Maybe(..), maybe)
import Data.StrMap as StrMap
import Data.StrMap(StrMap)
import Data.String(Pattern(..), split)
import Data.Traversable(traverse)
import Partial.Unsafe(unsafePartial)

import Ifrit.Parser as Parser
import Ifrit.Lexer as Lexer

data Schema
  = Object (StrMap Schema)
  | Array Schema
  | String
  | Number
  | Boolean
  | Null

fromJson :: String -> Either String Schema
fromJson =
  jsonParser >=> decodeJson

lookupProjection :: Schema -> StrMap Schema -> Parser.Projection -> Either String (StrMap Schema)
lookupProjection schema acc (Parser.Projection selector) =
  let
      lookupNumberProjection :: Partial => StrMap Schema -> Parser.Selector -> Either String (StrMap Schema)
      lookupNumberProjection source (Parser.Function f key as) =
        case split (Pattern ".") key of
          [_] ->
            case StrMap.lookup key source of
              Just (Array Number) ->
                Right $ StrMap.insert (maybe key (\x -> x) as) Number acc
              Just _ ->
                Left $ "invalid operation: function '" <> show f <> "' applied to non array<number>"
              Nothing ->
                Left $ "unexisting field: '" <> key <> "'"

          [base, key'] ->
            case StrMap.lookup base source of
              Just (Array (Object source')) ->
                case StrMap.lookup key' source' of
                  Just Number ->
                    Right $ StrMap.insert (maybe key' (\x -> x) as) Number acc
                  Just _ ->
                    Left $ "invalid operation: function '" <> show f <> "' applied to non number"
                  Nothing ->
                    Left $ "unexisting field: '" <> key <> "'"
              Just _ ->
                Left $ "invalid operation: function '" <> show f <> "': target isn't array<object>"

          _ ->
            Left $ "invalid field's name: '" <> key <> "'"
  in
      case { schema, selector } of
        { schema: Object source, selector: Parser.Selector key as } ->
          case StrMap.lookup key source of
            Just schema' ->
              Right $ StrMap.insert (maybe key (\x -> x) as) schema' acc

            Nothing ->
              Left $ "unexisting field: '" <> key <> "'"

        { schema: Object source, selector: f@(Parser.Function Lexer.Avg key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Count key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Max key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Min key as) } ->
          unsafePartial $ lookupNumberProjection source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Sum key as) } ->
          unsafePartial $ lookupNumberProjection source f

        _ ->
          Left "invalid operation: can't SELECT on non object"

lookupAggregation :: Schema -> StrMap Schema -> Parser.Aggregation -> Either String (StrMap Schema)
lookupAggregation schema acc (Parser.Aggregation selector) =
  let
      lookupNumberAggregation :: Partial => StrMap Schema -> Parser.Selector -> Either String (StrMap Schema)
      lookupNumberAggregation source (Parser.Function f key as) =
        case split (Pattern ".") key of
          [_] ->
            case StrMap.lookup key source of
              Just (Array Number) ->
                Right $ StrMap.insert (maybe key (\x -> x) as) Number acc
              Just _ ->
                Left $ "invalid operation: function '" <> show f <> "' applied to non array<number>"
              Nothing ->
                Left $ "unexisting field: '" <> key <> "'"

          _ ->
            Left $ "invalid field's name: '" <> key <> "'"
  in
      case { schema, selector } of
        { selector: Parser.Selector "_id" Nothing } ->
          Left $ "reserved field's name: _id"

        { selector: Parser.Selector _ (Just "_id") } ->
          Left $ "reserved field's name: _id"

        { selector: Parser.Function _ "_id" Nothing } ->
          Left $ "reserved field's name: _id"

        { selector: Parser.Function _ _ (Just "_id") } ->
          Left $ "reserved field's name: _id"

        { schema: Object source, selector: Parser.Selector key as } ->
          case StrMap.lookup key source of
            Just schema' ->
              Right $ StrMap.insert (maybe key (\x -> x) as) (Array schema') acc

            Nothing ->
              Left $ "unexisting field: '" <> key <> "'"

        { schema: Object source, selector: f@(Parser.Function Lexer.Avg key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Count key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Max key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Min key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        { schema: Object source, selector: f@(Parser.Function Lexer.Sum key as) } ->
          unsafePartial $ lookupNumberAggregation source f

        _ ->
          Left "invalid operation: can't SELECT on non object"

analyze :: Schema -> Parser.Statement -> Either String Schema
analyze schema (Parser.Select projections statement condition) = do
  schema' <- maybe (Right schema) (analyze schema) statement
  schema'' <- List.foldM (lookupProjection schema') StrMap.empty projections
  pure $ Object schema''

analyze schema (Parser.Group index aggregations statement condition) = do
  schema' <- maybe (Right schema) (analyze schema) statement
  schema'' <- List.foldM (lookupAggregation schema') StrMap.empty aggregations
  case index of
    Parser.IdxNull ->
      pure $ Object $ StrMap.insert "_id" Null schema''
    Parser.IdxField key ->
      case schema' of
        Object source ->
          case StrMap.lookup key source of
            Just schemaIndex ->
              pure $ Object $ StrMap.insert "_id" schemaIndex schema''
            Nothing ->
              Left $ "unexisting field: '" <> key <> "'"
        _ ->
          Left "invalid operation: can't SELECT on non object"

instance decodeSchema :: DecodeJson Schema where
  decodeJson =
    let
        decodeNull _ =
          Left "can't decode null to schema"
        decodeBoolean _ =
          Left "can't decode boolean to schema"
        decodeNumber _ =
          Left "can't decode number to schema"
        decodeString "string" =
          Right String
        decodeString "number" =
          Right Number
        decodeString "boolean" =
          Right Boolean
        decodeString "null" =
          Right Null
        decodeString s =
          Left ("can't decode type: invalid provided type: " <> s)
        decodeArray xs =
          if length xs /= 1
             then Left "can't decode array: exactly one element is expected"
             else case head xs of
               Nothing ->
                Left "can't decode array: exactly one element is expected"
               Just schema ->
                 Array <$> decodeJson schema
        decodeObject obj = Object <$> traverse decodeJson obj
    in
        foldJson decodeNull decodeBoolean decodeNumber decodeString decodeArray decodeObject

instance encodeJsonSchema :: EncodeJson Schema where
  encodeJson (Object schema) =
    encodeJson $ map encodeJson schema
  encodeJson (Array schema) =
    encodeJson [encodeJson schema]
  encodeJson Number =
    encodeJson "number"
  encodeJson String =
    encodeJson "string"
  encodeJson Boolean =
    encodeJson "boolean"
  encodeJson Null =
    encodeJson "null"

instance showSchema :: EncodeJson Schema => Show Schema where
  show = encodeJson >>> stringify

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


Add TypeClassDictionaries

Add TypeClassDictionaries

module Language.PureScript.TypeClassDictionaries where

import Data.Maybe
import Data.Tuple

import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Show

-- |
-- Data representing a type class dictionary which is in scope
--
data TypeClassDictionaryInScope = TypeClassDictionaryInScope
  {
    -- |
    -- The identifier with which the dictionary can be accessed at runtime
    --
      tcdName :: Qualified Ident
    -- |
    -- The name of the type class to which this type class instance applies
    --
    , tcdClassName :: Qualified ProperName
    -- |
    -- The types to which this type class instance applies
    --
    , tcdInstanceTypes :: [Type]
    -- |
    -- Type class dependencies which must be satisfied to construct this dictionary
    --
    , tcdDependencies :: Maybe [Tuple (Qualified ProperName) [Type]]
    -- |
    -- The type of this dictionary
    --
    , tcdType :: TypeClassDictionaryType
    }

instance showTCDIS :: Show TypeClassDictionaryInScope where
  show = defaultShow

-- |
-- The type of a type class dictionary
--
data TypeClassDictionaryType
  -- |
  -- A regular type class dictionary
  --
  = TCDRegular
  -- |
  -- A type class dictionary which is an alias for an imported dictionary from another module
  --
  | TCDAlias (Qualified Ident)

instance showTCDT :: Show TypeClassDictionaryType where
  show = defaultShow

instance eqTCDT :: Eq TypeClassDictionaryType where
  (==) TCDRegular    TCDRegular = true
  (==) (TCDAlias q1) (TCDAlias q2) = true
  (==) _ _ = false
  (/=) x y = not (x == y)

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


WIP on quantitative scales

WIP on quantitative scales

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


Minor change. Logging output of spread() in tests.


Fixed checkbox rendering

Fixed checkbox rendering

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/garyb/purescript-markdown-halogen.git/'