Remove unnecessary import

Remove unnecessary import

-- | 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
  , lookupLE
  , lookupLT
  , lookupGE
  , lookupGT
  , findMin
  , findMax
  , fromFoldable
  , fromFoldableWith
  , toList
  , toUnfoldable
  , delete
  , pop
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  , mapWithKey
  ) where

import Prelude

import Data.Foldable (foldl, foldMap, foldr, class Foldable)
import Data.List (List(..), (:), length, nub)
import Data.Maybe (Maybe(..), maybe, isJust, fromMaybe)
import Data.Monoid (class Monoid)
import Data.Traversable (traverse, class Traversable)
import Data.Tuple (Tuple(Tuple), snd)
import Data.Unfoldable (class Unfoldable, unfoldr)

import Partial.Unsafe (unsafePartial)

-- | `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 ordMap :: (Ord k, Ord v) => Ord (Map k v) where
  compare m1 m2 = compare (toList m1) (toList m2)

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

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 :: Traversable (Map k) where
  traverse f Leaf = pure Leaf
  traverse f (Two left k v right) =
    Two <$> traverse f left
        <*> pure k
        <*> f v
        <*> traverse f right
  traverse f (Three left k1 v1 mid k2 v2 right) =
    Three <$> traverse f left
          <*> pure k1
          <*> f v1
          <*> traverse f mid
          <*> pure k2
          <*> f v2
          <*> traverse f right
  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 = unsafePartial \k tree ->
  case tree of
    Leaf -> Nothing
    _ ->
      let comp :: k -> k -> Ordering
          comp = compare
      in case tree of
        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 c1, comp k k2 of
                _ , EQ -> Just v2
                LT, _  -> lookup k left
                _ , GT -> lookup k right
                _ , _  -> lookup k mid

-- | Lookup a value for the specified key, or the greatest one less than it
lookupLE :: forall k v. (Ord k) => k -> Map k v -> Maybe { key :: k, value :: v }
lookupLE _ Leaf = Nothing
lookupLE k (Two left k1 v1 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  GT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupLE k right
  LT -> lookupLE k left
lookupLE k (Three left k1 v1 mid k2 v2 right) = case compare k k2 of
  EQ -> Just { key: k2, value: v2 }
  GT -> Just $ fromMaybe { key: k2, value: v2 } $ lookupLE k right
  LT -> lookupLE k $ Two left k1 v1 mid

-- | Lookup a value for the greatest key less than the specified key
lookupLT :: forall k v. (Ord k) => k -> Map k v -> Maybe { key :: k, value :: v }
lookupLT _ Leaf = Nothing
lookupLT k (Two left k1 v1 right) = case compare k k1 of
  EQ -> findMax left
  GT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupLT k right
  LT -> lookupLT k left
lookupLT k (Three left k1 v1 mid k2 v2 right) = case compare k k2 of
  EQ -> findMax $ Two left k1 v1 mid
  GT -> Just $ fromMaybe { key: k2, value: v2 } $ lookupLT k right
  LT -> lookupLT k $ Two left k1 v1 mid

-- | Lookup a value for the specified key, or the least one greater than it
lookupGE :: forall k v. (Ord k) => k -> Map k v -> Maybe { key :: k, value :: v }
lookupGE _ Leaf = Nothing
lookupGE k (Two left k1 v1 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGE k left
  GT -> lookupGE k right
lookupGE k (Three left k1 v1 mid k2 v2 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGE k left
  GT -> lookupGE k $ Two mid k2 v2 right

-- | Lookup a value for the least key greater than the specified key
lookupGT :: forall k v. (Ord k) => k -> Map k v -> Maybe { key :: k, value :: v }
lookupGT _ Leaf = Nothing
lookupGT k (Two left k1 v1 right) = case compare k k1 of
  EQ -> findMin right
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGT k left
  GT -> lookupGT k right
lookupGT k (Three left k1 v1 mid k2 v2 right) = case compare k k1 of
  EQ -> findMin $ Two mid k2 v2 right
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGT k left
  GT -> lookupGT k $ Two mid k2 v2 right

-- | Returns the pair with the greatest key
findMax :: forall k v. Map k v -> Maybe { key :: k, value :: v }
findMax Leaf = Nothing
findMax (Two _ k1 v1 right) = Just $ fromMaybe { key: k1, value: v1 } $ findMax right
findMax (Three _ _ _ _ k2 v2 right) = Just $ fromMaybe { key: k2, value: v2 } $ findMax right

-- | Returns the pair with the least key
findMin :: forall k v. Map k v -> Maybe { key :: k, value :: v }
findMin Leaf = Nothing
findMin (Two left k1 v1 _) = Just $ fromMaybe { key: k1, value: v1 } $ findMin left
findMin (Three left k1 v1 _ _ _ _) = Just $ fromMaybe { key: k1, value: v1 } $ findMin left

-- | 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 c1, comp k k2 of
          _ , EQ -> fromZipper ctx (Three left k1 v1 mid k v right)
          LT, _  -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k v left
          GT, 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

  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) kup =
    case x, kup of
      TwoLeft k1 v1 right, KickUp left k v mid -> fromZipper ctx (Three left k v mid k1 v1 right)
      TwoRight left k1 v1, KickUp mid k v right -> fromZipper ctx (Three left k1 v1 mid k v right)
      ThreeLeft k1 v1 c k2 v2 d, KickUp a k v b -> up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
      ThreeMiddle a k1 v1 k2 v2 d, KickUp b k v c -> up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
      ThreeRight a k1 v1 b k2 v2, 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 k m = maybe m snd (pop k m)

-- | Delete a key and its corresponding value from a map, returning the value
-- | as well as the subsequent map.
pop :: forall k v. Ord k => k -> Map k v -> Maybe (Tuple v (Map k v))
pop = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> k -> Map k v -> Maybe (Tuple v (Map k v))
  down = unsafePartial \ctx k m -> case m of
    Leaf -> Nothing
    Two left k1 v1 right ->
      case right, comp k k1 of
        Leaf, EQ -> Just (Tuple v1 (up ctx Leaf))
        _   , EQ -> let max = maxNode left
                     in Just (Tuple v1 (removeMaxNode (Cons (TwoLeft max.key max.value right) ctx) left))
        _   , LT -> down (Cons (TwoLeft k1 v1 right) ctx) k left
        _   , _  -> down (Cons (TwoRight left k1 v1) ctx) k right
    Three left k1 v1 mid k2 v2 right ->
      let leaves =
            case left, mid, right of
              Leaf, Leaf, Leaf -> true
              _   , _   , _    -> false
      in case leaves, comp k k1, comp k k2 of
        true, EQ, _  -> Just (Tuple v1 (fromZipper ctx (Two Leaf k2 v2 Leaf)))
        true, _ , EQ -> Just (Tuple v2 (fromZipper ctx (Two Leaf k1 v1 Leaf)))
        _   , EQ, _  -> let max = maxNode left
                         in Just (Tuple v1 (removeMaxNode (Cons (ThreeLeft max.key max.value mid k2 v2 right) ctx) left))
        _   , _ , EQ -> let max = maxNode mid
                         in Just (Tuple v2 (removeMaxNode (Cons (ThreeMiddle left k1 v1 max.key max.value right) ctx) mid))
        _   , LT, _  -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k left
        _   , GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k mid
        _   , _ , _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k right

  up :: List (TreeContext k v) -> Map k v -> Map k v
  up = unsafePartial \ctxs tree ->
    case ctxs of
      Nil -> tree
      Cons x ctx ->
        case x, tree of
          TwoLeft k1 v1 Leaf, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf)
          TwoRight Leaf k1 v1, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf)
          TwoLeft k1 v1 (Two m k2 v2 r), l -> up ctx (Three l k1 v1 m k2 v2 r)
          TwoRight (Two l k1 v1 m) k2 v2, r -> up ctx (Three l k1 v1 m k2 v2 r)
          TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d), a -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
          TwoRight (Three a k1 v1 b k2 v2 c) k3 v3, d -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
          ThreeLeft k1 v1 Leaf k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeMiddle Leaf k1 v1 k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeRight Leaf k1 v1 Leaf k2 v2, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d, a -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
          ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d, c -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
          ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d), b -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
          ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3, d -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
          ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e, a -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
          ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e, d -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
          ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e), b -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
          ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4, e -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))

  maxNode :: Map k v -> { key :: k, value :: v }
  maxNode = unsafePartial \m -> case m of
    Two _ k v Leaf -> { key: k, value: v }
    Two _ _ _ right -> maxNode right
    Three _ _ _ _ k v Leaf -> { key: k, value: v }
    Three _ _ _ _ _ _ right -> maxNode right

  removeMaxNode :: List (TreeContext k v) -> Map k v -> Map k v
  removeMaxNode = unsafePartial \ctx m ->
    case m of
      Two Leaf _ _ Leaf -> up ctx Leaf
      Two left k v right -> removeMaxNode (Cons (TwoRight left k v) ctx) right
      Three Leaf k1 v1 Leaf _ _ Leaf -> up (Cons (TwoRight Leaf k1 v1) ctx) Leaf
      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 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 <> Tuple k v : toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left <> Tuple k1 v1 : toList mid <> Tuple k2 v2 : toList right

-- | Convert a map to an unfoldable structure of key/value pairs
toUnfoldable :: forall f k v. (Ord k, Unfoldable f) => Map k v -> f (Tuple k v)
toUnfoldable = unfoldr go
  where
  go :: Map k v -> Maybe (Tuple (Tuple k v) (Map k v))
  go Leaf = Nothing
  go (Two left k v right) = Just $ Tuple (Tuple k v) (left <> right)
  go (Three left k1 v1 mid k2 v2 right) = Just $ Tuple (Tuple k1 v1) (insert k2 v2 (left <> mid <> right))

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

-- | Apply a function of two arguments to each key/value pair, producing a new map
mapWithKey :: forall k v v'. (k -> v -> v') -> Map k v -> Map k v'
mapWithKey _ Leaf = Leaf
mapWithKey f (Two left k v right) = Two (mapWithKey f left) k (f k v) (mapWithKey f right)
mapWithKey f (Three left k1 v1 mid k2 v2 right) = Three (mapWithKey f left) k1 (f k1 v1) (mapWithKey f mid) k2 (f k2 v2) (mapWithKey f right)

-- | 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
  , lookupLE
  , lookupLT
  , lookupGE
  , lookupGT
  , findMin
  , findMax
  , fromFoldable
  , fromFoldableWith
  , toList
  , toUnfoldable
  , delete
  , pop
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  , mapWithKey
  ) where

import Prelude

import Data.Foldable (foldl, foldMap, foldr, class Foldable)
import Data.List (List(..), (:), length, nub)
import Data.Maybe (Maybe(..), maybe, isJust, fromMaybe)
import Data.Monoid (class Monoid)
import Data.Traversable (traverse, class Traversable)
import Data.Tuple (Tuple(..), uncurry, snd)
import Data.Unfoldable (class Unfoldable, unfoldr)

import Partial.Unsafe (unsafePartial)

-- | `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 ordMap :: (Ord k, Ord v) => Ord (Map k v) where
  compare m1 m2 = compare (toList m1) (toList m2)

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

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 :: Traversable (Map k) where
  traverse f Leaf = pure Leaf
  traverse f (Two left k v right) =
    Two <$> traverse f left
        <*> pure k
        <*> f v
        <*> traverse f right
  traverse f (Three left k1 v1 mid k2 v2 right) =
    Three <$> traverse f left
          <*> pure k1
          <*> f v1
          <*> traverse f mid
          <*> pure k2
          <*> f v2
          <*> traverse f right
  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 = unsafePartial \k tree ->
  case tree of
    Leaf -> Nothing
    _ ->
      let comp :: k -> k -> Ordering
          comp = compare
      in case tree of
        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 c1, comp k k2 of
                _ , EQ -> Just v2
                LT, _  -> lookup k left
                _ , GT -> lookup k right
                _ , _  -> lookup k mid

-- | Lookup a value for the specified key, or the greatest one less than it
lookupLE :: forall k v. (Ord k) => k -> Map k v -> Maybe { key :: k, value :: v }
lookupLE _ Leaf = Nothing
lookupLE k (Two left k1 v1 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  GT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupLE k right
  LT -> lookupLE k left
lookupLE k (Three left k1 v1 mid k2 v2 right) = case compare k k2 of
  EQ -> Just { key: k2, value: v2 }
  GT -> Just $ fromMaybe { key: k2, value: v2 } $ lookupLE k right
  LT -> lookupLE k $ Two left k1 v1 mid

-- | Lookup a value for the greatest key less than the specified key
lookupLT :: forall k v. (Ord k) => k -> Map k v -> Maybe { key :: k, value :: v }
lookupLT _ Leaf = Nothing
lookupLT k (Two left k1 v1 right) = case compare k k1 of
  EQ -> findMax left
  GT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupLT k right
  LT -> lookupLT k left
lookupLT k (Three left k1 v1 mid k2 v2 right) = case compare k k2 of
  EQ -> findMax $ Two left k1 v1 mid
  GT -> Just $ fromMaybe { key: k2, value: v2 } $ lookupLT k right
  LT -> lookupLT k $ Two left k1 v1 mid

-- | Lookup a value for the specified key, or the least one greater than it
lookupGE :: forall k v. (Ord k) => k -> Map k v -> Maybe { key :: k, value :: v }
lookupGE _ Leaf = Nothing
lookupGE k (Two left k1 v1 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGE k left
  GT -> lookupGE k right
lookupGE k (Three left k1 v1 mid k2 v2 right) = case compare k k1 of
  EQ -> Just { key: k1, value: v1 }
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGE k left
  GT -> lookupGE k $ Two mid k2 v2 right

-- | Lookup a value for the least key greater than the specified key
lookupGT :: forall k v. (Ord k) => k -> Map k v -> Maybe { key :: k, value :: v }
lookupGT _ Leaf = Nothing
lookupGT k (Two left k1 v1 right) = case compare k k1 of
  EQ -> findMin right
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGT k left
  GT -> lookupGT k right
lookupGT k (Three left k1 v1 mid k2 v2 right) = case compare k k1 of
  EQ -> findMin $ Two mid k2 v2 right
  LT -> Just $ fromMaybe { key: k1, value: v1 } $ lookupGT k left
  GT -> lookupGT k $ Two mid k2 v2 right

-- | Returns the pair with the greatest key
findMax :: forall k v. Map k v -> Maybe { key :: k, value :: v }
findMax Leaf = Nothing
findMax (Two _ k1 v1 right) = Just $ fromMaybe { key: k1, value: v1 } $ findMax right
findMax (Three _ _ _ _ k2 v2 right) = Just $ fromMaybe { key: k2, value: v2 } $ findMax right

-- | Returns the pair with the least key
findMin :: forall k v. Map k v -> Maybe { key :: k, value :: v }
findMin Leaf = Nothing
findMin (Two left k1 v1 _) = Just $ fromMaybe { key: k1, value: v1 } $ findMin left
findMin (Three left k1 v1 _ _ _ _) = Just $ fromMaybe { key: k1, value: v1 } $ findMin left

-- | 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 c1, comp k k2 of
          _ , EQ -> fromZipper ctx (Three left k1 v1 mid k v right)
          LT, _  -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k v left
          GT, 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

  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) kup =
    case x, kup of
      TwoLeft k1 v1 right, KickUp left k v mid -> fromZipper ctx (Three left k v mid k1 v1 right)
      TwoRight left k1 v1, KickUp mid k v right -> fromZipper ctx (Three left k1 v1 mid k v right)
      ThreeLeft k1 v1 c k2 v2 d, KickUp a k v b -> up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
      ThreeMiddle a k1 v1 k2 v2 d, KickUp b k v c -> up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
      ThreeRight a k1 v1 b k2 v2, 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 k m = maybe m snd (pop k m)

-- | Delete a key and its corresponding value from a map, returning the value
-- | as well as the subsequent map.
pop :: forall k v. Ord k => k -> Map k v -> Maybe (Tuple v (Map k v))
pop = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> k -> Map k v -> Maybe (Tuple v (Map k v))
  down = unsafePartial \ctx k m -> case m of
    Leaf -> Nothing
    Two left k1 v1 right ->
      case right, comp k k1 of
        Leaf, EQ -> Just (Tuple v1 (up ctx Leaf))
        _   , EQ -> let max = maxNode left
                     in Just (Tuple v1 (removeMaxNode (Cons (TwoLeft max.key max.value right) ctx) left))
        _   , LT -> down (Cons (TwoLeft k1 v1 right) ctx) k left
        _   , _  -> down (Cons (TwoRight left k1 v1) ctx) k right
    Three left k1 v1 mid k2 v2 right ->
      let leaves =
            case left, mid, right of
              Leaf, Leaf, Leaf -> true
              _   , _   , _    -> false
      in case leaves, comp k k1, comp k k2 of
        true, EQ, _  -> Just (Tuple v1 (fromZipper ctx (Two Leaf k2 v2 Leaf)))
        true, _ , EQ -> Just (Tuple v2 (fromZipper ctx (Two Leaf k1 v1 Leaf)))
        _   , EQ, _  -> let max = maxNode left
                         in Just (Tuple v1 (removeMaxNode (Cons (ThreeLeft max.key max.value mid k2 v2 right) ctx) left))
        _   , _ , EQ -> let max = maxNode mid
                         in Just (Tuple v2 (removeMaxNode (Cons (ThreeMiddle left k1 v1 max.key max.value right) ctx) mid))
        _   , LT, _  -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k left
        _   , GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k mid
        _   , _ , _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k right

  up :: List (TreeContext k v) -> Map k v -> Map k v
  up = unsafePartial \ctxs tree ->
    case ctxs of
      Nil -> tree
      Cons x ctx ->
        case x, tree of
          TwoLeft k1 v1 Leaf, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf)
          TwoRight Leaf k1 v1, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf)
          TwoLeft k1 v1 (Two m k2 v2 r), l -> up ctx (Three l k1 v1 m k2 v2 r)
          TwoRight (Two l k1 v1 m) k2 v2, r -> up ctx (Three l k1 v1 m k2 v2 r)
          TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d), a -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
          TwoRight (Three a k1 v1 b k2 v2 c) k3 v3, d -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
          ThreeLeft k1 v1 Leaf k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeMiddle Leaf k1 v1 k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeRight Leaf k1 v1 Leaf k2 v2, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
          ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d, a -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
          ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d, c -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
          ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d), b -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
          ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3, d -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
          ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e, a -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
          ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e, d -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
          ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e), b -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
          ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4, e -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))

  maxNode :: Map k v -> { key :: k, value :: v }
  maxNode = unsafePartial \m -> case m of
    Two _ k v Leaf -> { key: k, value: v }
    Two _ _ _ right -> maxNode right
    Three _ _ _ _ k v Leaf -> { key: k, value: v }
    Three _ _ _ _ _ _ right -> maxNode right

  removeMaxNode :: List (TreeContext k v) -> Map k v -> Map k v
  removeMaxNode = unsafePartial \ctx m ->
    case m of
      Two Leaf _ _ Leaf -> up ctx Leaf
      Two left k v right -> removeMaxNode (Cons (TwoRight left k v) ctx) right
      Three Leaf k1 v1 Leaf _ _ Leaf -> up (Cons (TwoRight Leaf k1 v1) ctx) Leaf
      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 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 <> Tuple k v : toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left <> Tuple k1 v1 : toList mid <> Tuple k2 v2 : toList right

-- | Convert a map to an unfoldable structure of key/value pairs
toUnfoldable :: forall f k v. (Ord k, Unfoldable f) => Map k v -> f (Tuple k v)
toUnfoldable = unfoldr go
  where
  go :: Map k v -> Maybe (Tuple (Tuple k v) (Map k v))
  go Leaf = Nothing
  go (Two left k v right) = Just $ Tuple (Tuple k v) (left <> right)
  go (Three left k1 v1 mid k2 v2 right) = Just $ Tuple (Tuple k1 v1) (insert k2 v2 (left <> mid <> right))

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

-- | Apply a function of two arguments to each key/value pair, producing a new map
mapWithKey :: forall k v v'. (k -> v -> v') -> Map k v -> Map k v'
mapWithKey _ Leaf = Leaf
mapWithKey f (Two left k v right) = Two (mapWithKey f left) k (f k v) (mapWithKey f right)
mapWithKey f (Three left k1 v1 mid k2 v2 right) = Three (mapWithKey f left) k1 (f k1 v1) (mapWithKey f mid) k2 (f k2 v2) (mapWithKey f right)


Better error message

Better error message

module Main where

import Prelude
import Data.Either
import Data.Maybe
import App.Layout (Action(..))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error)
import Data.URI.Types (HierarchicalPart(..))

import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Location (pathname)
import DOM.HTML.Window(location)
import Data.URI as U
import Data.Path.Pathy((</>),dir,file,rootDir)
--import Debug.Trace (traceAnyM)

import Pux (App, Config, CoreEffects, fromSimple, renderToDOM, start)
import Pux.Devtool (Action, start) as Pux.Devtool
import Pux.Router (sampleUrl)

import Signal ((~>),Signal)
import Signal.Channel (channel, subscribe, CHANNEL)

import WebSocket(WEBSOCKET)

import App.Layout (Action(..), State, view, update, init)
import App.Routes (match,Route)
import App.StatsSocket as Socket

type AppEffects = (dom :: DOM, ws :: WEBSOCKET)

-- | App configuration
config :: forall eff. State -> Eff (dom :: DOM, channel :: CHANNEL, err :: EXCEPTION, ws :: WEBSOCKET | eff) (Config State Action AppEffects)
config state = do
  -- | Create a signal of URL changes.
  routeSignal <- getRouteSignal
  -- | Create a signal for WebSocket stats data
  socketSignal <- getSocketSignal
  pure
    { initialState: state
    , update: fromSimple update
    , view: view
    , inputs:
        [ routeSignal ~> match ~> PageView
        , socketSignal ~> Received ] }

getSocketSignal :: forall eff. Eff (dom :: DOM, err :: EXCEPTION, channel :: CHANNEL, ws :: WEBSOCKET | eff) (Signal Socket.Action)
getSocketSignal = do
  wsUrl <- getWsUrl
  wsInput <- channel Socket.Starting
  statsSig <- Socket.setupWs wsInput wsUrl
  pure $ subscribe wsInput

getRouteSignal :: forall eff. Eff (dom :: DOM | eff) (Signal String)
getRouteSignal = do
  urlSignal <- sampleUrl
  pure $ urlSignal

getWsUrl :: forall eff. Eff (dom :: DOM, err :: EXCEPTION | eff) String
getWsUrl = window >>= location >>= pathname >>= convertToWsUrl

convertToWsUrl :: forall eff. String -> Eff (err :: EXCEPTION | eff) String
convertToWsUrl url =
  case U.runParseURI url of
    Right
      (U.URI _
        h@(U.HierarchicalPart auth@(Just _) _ )
       _  _
      ) ->
      let wsScheme = Just (U.URIScheme "ws")
          wsPath = (Just (Right (rootDir </> dir "ws" </> file "stats")))
          wsH = U.HierarchicalPart auth wsPath
      in
      pure $ U.printURI $ U.URI wsScheme wsH Nothing Nothing
    _ ->
      let msg = "Could not convert " <> url <> "to the stats websocket URL" in
      throwException $ error msg

-- | Entry point for the browser.
main :: Eff (CoreEffects AppEffects) (App State Action)
main = do
    app <- start =<< config init
    renderToDOM "#app" app.html
    pure app

-- | Entry point for the browser with pux-devtool injected.
debug :: State -> Eff (CoreEffects AppEffects) (App State (Pux.Devtool.Action Action))
debug state = do
  app <- Pux.Devtool.start =<< config state
  renderToDOM "#app" app.html
  -- | Used by hot-reloading code in support/index.js
  pure app

module Main where

import Prelude
import Data.Either
import Data.Maybe
import App.Layout (Action(..))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error)
import Data.URI.Types (HierarchicalPart(..))

import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Location (pathname)
import DOM.HTML.Window(location)
import Data.URI as U
import Data.Path.Pathy((</>),dir,file,rootDir)
--import Debug.Trace (traceAnyM)

import Pux (App, Config, CoreEffects, fromSimple, renderToDOM, start)
import Pux.Devtool (Action, start) as Pux.Devtool
import Pux.Router (sampleUrl)

import Signal ((~>),Signal)
import Signal.Channel (channel, subscribe, CHANNEL)

import WebSocket(WEBSOCKET)

import App.Layout (Action(..), State, view, update, init)
import App.Routes (match,Route)
import App.StatsSocket as Socket

type AppEffects = (dom :: DOM, ws :: WEBSOCKET)

-- | App configuration
config :: forall eff. State -> Eff (dom :: DOM, channel :: CHANNEL, err :: EXCEPTION, ws :: WEBSOCKET | eff) (Config State Action AppEffects)
config state = do
  -- | Create a signal of URL changes.
  routeSignal <- getRouteSignal
  -- | Create a signal for WebSocket stats data
  socketSignal <- getSocketSignal
  pure
    { initialState: state
    , update: fromSimple update
    , view: view
    , inputs:
        [ routeSignal ~> match ~> PageView
        , socketSignal ~> Received ] }

getSocketSignal :: forall eff. Eff (dom :: DOM, err :: EXCEPTION, channel :: CHANNEL, ws :: WEBSOCKET | eff) (Signal Socket.Action)
getSocketSignal = do
  wsUrl <- getWsUrl
  wsInput <- channel Socket.Starting
  statsSig <- Socket.setupWs wsInput wsUrl
  pure $ subscribe wsInput

getRouteSignal :: forall eff. Eff (dom :: DOM | eff) (Signal String)
getRouteSignal = do
  urlSignal <- sampleUrl
  pure $ urlSignal

getWsUrl :: forall eff. Eff (dom :: DOM, err :: EXCEPTION | eff) String
getWsUrl = window >>= location >>= pathname >>= convertToWsUrl

convertToWsUrl :: forall eff. String -> Eff (err :: EXCEPTION | eff) String
convertToWsUrl url =
  case U.runParseURI url of
    Right
      (U.URI _
        h@(U.HierarchicalPart auth@(Just _) _ )
       _  _
      ) ->
      let wsScheme = Just (U.URIScheme "ws")
          wsPath = (Just (Right (rootDir </> dir "ws" </> file "stats")))
          wsH = U.HierarchicalPart auth wsPath
      in
      pure $ U.printURI $ U.URI wsScheme wsH Nothing Nothing
    _ -> throwException $ error "Could not get the URL for the stats websocket"

-- | Entry point for the browser.
main :: Eff (CoreEffects AppEffects) (App State Action)
main = do
    app <- start =<< config init
    renderToDOM "#app" app.html
    pure app

-- | Entry point for the browser with pux-devtool injected.
debug :: State -> Eff (CoreEffects AppEffects) (App State (Pux.Devtool.Action Action))
debug state = do
  app <- Pux.Devtool.start =<< config state
  renderToDOM "#app" app.html
  -- | Used by hot-reloading code in support/index.js
  pure app


Factor out guardAccountUnlocked in view

Factor out guardAccountUnlocked in view

module App.View where

import Text.Smolder.HTML hiding (address)

import App.Routing (Location(..))
import App.State (Event(..), State, signerLens)
import App.State.Contracts as Contracts
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Locations as Locations
import App.State.Signers as Signers
import Data.Array (fromFoldable)
import Data.Either (Either(..))
import Data.Lens ((^.))
import Data.Map (toUnfoldable, values)
import Data.Maybe (Maybe(..), fromJust, isJust, maybe)
import Data.String (drop, length, take, toLower)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.Eth.Contracts (class EthContract, getAddress)
import Lib.Eth.Web3 (TxHash(..), TxStatus(..))
import Lib.SignHash.Proofs.Display (SignerDisplayStatus(..), signerDisplayStatus)
import Lib.SignHash.Proofs.Methods (ProofMethod(..), canonicalName)
import Lib.SignHash.Proofs.Types (ProofState(..), ProofVerification(..))
import Lib.SignHash.Proofs.Values as ProofValues
import Lib.SignHash.Types (Address(..), HashSigner(..))
import Partial.Unsafe (unsafePartial)
import Prelude (discard, show, ($), (-), (<<<), (<>))
import Pux.DOM.Events (DOMEvent, onChange, onClick, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML.Attributes (className, for, id, src, type')
import Text.Smolder.HTML.Attributes as A
import Text.Smolder.Markup (Attribute, EventHandlers, attribute, text, (!), (#!))

foreign import images ::
  { logo :: String
  , ethIcon :: String }

dataQA :: String -> Attribute
dataQA = attribute "data-qa"

view :: State -> HTML Event
view state =
  do
    div ! className "Content" $ do
      div ! className "Header" $ do
        img ! src images.logo
        span ! className "title" $ text "SignHash"

      nav ! className "Navbar" $ do
        ul do
          li $ a ! A.href "#" #! onClick (navigate Sign) $ text "Sign"
          li $ a ! A.href "#" #! onClick (navigate Verify) $ text "Verify"

      viewContent state

      hr
      div ! className "Contracts-info" $ do
        viewContracts state.contracts
      clear

viewContent :: State -> HTML Event
viewContent state@{ location: Verify } = do
  viewFileInput "Verify" (isJust state.file)
  case state.file of
    Nothing -> empty
    Just file -> do
      viewFile file
      viewFileSigners state file
viewContent state@{ location: Sign } = do
  viewFileInput "Sign" (isJust state.file)
  case state.file of
    Nothing -> empty
    Just file -> do
      viewFile file
      sectionHeader "Your account"
      guardAccountUnlocked state.myAccount $ viewSigningDetails state file

viewFileSigners :: State -> Files.State -> HTML Event
viewFileSigners state file = do
  div $ signerStatus file.signer
  where
    signerStatus = case _ of
      Nothing -> sectionHeader "Loading signer..."
      Just (NoSigner) -> sectionHeader "No signers"
      Just (HashSigner address) -> do
        sectionHeader "Signers"
        case state ^. signerLens address of
          Nothing -> div do
            text loading
            hr
          Just value -> div do
            child (Signer address) viewSigner $ value

viewSigningDetails :: State -> Files.State -> Address -> HTML Event
viewSigningDetails state file address = do
  div ! dataQA "my-id" $ do
    let myDetails = expectResult $ state ^. signerLens address
    child (Signer address) viewSigner myDetails
    case file.result of
      Nothing -> empty
      Just fileDetails ->
        case state.signingTx of
          Nothing ->
            a
              ! A.href "#"
              ! dataQA "sign"
              #! onClickAction (SignFile fileDetails.hash)
              $ text "Sign it"
          Just (Left err) ->
            text $ "Error while issuing transaction"
          Just (Right hash) -> do
            text $ "Issued tx "
            let txStatus = Contracts.viewTxResult hash state.contracts
            txLink hash txStatus

viewContracts :: Contracts.State -> HTML Event
viewContracts Contracts.Loading =
  text $ "Loading contract..."
viewContracts (Contracts.Loaded state) = do
  contractLink "SignHash" state.signHash
  br
  contractLink "SignProof" state.signProof
  where
    contractLink :: forall c. EthContract c => String -> c -> HTML Event
    contractLink name contract = do
      span $ text $ name <> ": "
      (addressLink $ getAddress contract)
        ! dataQA ((toLower name) <> "-address")

viewContracts (Contracts.Error err) = do
  div
    ! A.title err
    $ text "Error while loading contract"

viewFileInput :: String -> Boolean -> HTML Event
viewFileInput verb small =
  div do
    label
      ! for "file-upload"
      ! className ("File-upload" <> if small then " small" else "")
      #! onDrop handleNewFiles
      #! onDragOver ignoreEvent
      $ do
        renderIcon "fa-file-o"
        text (verb <> " a file")
        if small then empty else
          div ! className "hint"
          $ text "Click or drag and drop on the page"
    input
      ! id "file-upload"
      ! type' "file"
      #! onChange handleNewFiles
  where
    handleNewFiles ev =
      preventingDefault (FileInput $ FileInputs.newFilesEvent ev) ev

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } = do
  div ! className "Files Section" $ do
    div ! className "row" $ do
      renderRow "Filename" $ text $ meta.name
      renderRow "SHA256" $ maybe (text loading) renderHash result
      renderRow "Size" $ renderSize meta.size

  where
    renderRow label value =
      div ! className "columns attribute four" $ do
        span ! className "header" $ text (label <> ":")
        span ! className "value" $ value

    renderSigner (HashSigner address) = show address
    renderSigner NoSigner = "Not signed"

    renderHash { hash } =
      let visibleOffset = 6
      in a
         ! dataQA "checksum"
         ! A.title hash
         ! A.href "#"
         $ text $ take visibleOffset hash
           <> "..."
           <> drop (length hash - visibleOffset) hash

    renderSize size = text $ show meta.size <> " B"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs, blockie } = do
  div ! className "Signer" $ do
    div ! className "header" $ do
      span ! className "status" $ do
        viewSignerStatus
    viewProofs address proofArray
    clear
  where
    proofStates = fromFoldable $ values proofs

    proofArray :: Array (Tuple ProofMethod ProofState)
    proofArray = toUnfoldable proofs

    viewSignerStatus =
      case signerDisplayStatus proofStates of
        SignerLoading -> renderIcon "fa-circle-o-notch loading"
        SignerVerified -> renderBlockie blockie
        SignerVerificationFailed -> renderIcon "fa-exclamation-circle failed"
        SignerNetworkError -> renderIcon "fa-question-circle-o network-error"

viewProofs ::
  Address
  -> Array (Tuple ProofMethod ProofState)
  -> HTML Signers.Event
viewProofs address proofs =
  div ! className "proofs" $ do
    renderEthProof
    for_ proofs renderProof
  where
    renderProof (Tuple method state) = do
      case state of
        Finished result -> renderFinishedProof method result
        NetworkError -> renderNetworkError method
        Pending -> empty

    renderFinishedProof method Unavailable = empty
    renderFinishedProof method (Unverified error) =
      div
        ! className ("proof " <> "failed")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          span ! dataQA "error" ! A.title (show error)
            $ text $ show method <> " verification failed"

    renderFinishedProof method (Verified proofValue) =
      div
        ! className ("proof " <> "verified")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          a ! A.href (methodHref method proof) ! A.target "_blank" $ text proof
      where
        proof = ProofValues.extract proofValue

    renderNetworkError method =
      div ! className ("proof" <> "network-error") $ do
        methodIcon method
        text $ "Network error while fetching proof"

    renderEthProof =
      div ! className "proof" $ do
        renderEthIcon
        (addressLink address) ! dataQA "proof-details-eth"

    methodIcon GitHub = renderIcon "fa-github"
    methodIcon HTTP = renderIcon "fa-world"

    methodHref GitHub username =
      "https://github.com/" <> username
    methodHref HTTP domain =
      "http://" <> domain

guardAccountUnlocked ::
  Contracts.ETHAccountState Address -> (Address -> HTML Event) -> HTML Event
guardAccountUnlocked state view = do
  case state of
    Contracts.Unavailable -> h4 $ text $ "Please install MetaMask extension"
    Contracts.Locked -> h4 $ text $ "Please unlock MetaMask"
    Contracts.Available address -> view address

sectionHeader :: forall a. String -> HTML a
sectionHeader msg =
  h4 ! className "Section-header" $ text msg

renderIcon :: forall a. String -> HTML a
renderIcon name = i ! className ("fa fa-lg " <> name) $ text ""

renderEthIcon :: forall a. Html a
renderEthIcon =
  img
  ! className "Icon"
  ! src images.ethIcon

renderBlockie :: forall a. String -> HTML a
renderBlockie blockieSrc =
  img ! className "blockie" ! src blockieSrc

loading :: String
loading = "Loading..."

empty :: forall a. HTML a
empty = text ""

clear :: forall a. HTML a
clear = div ! className "Clear" $ empty

addressLink :: forall a. Address -> HTML a
addressLink address = do
  a
  ! A.href (addressURL address)
  ! className "AddressURL"
  ! A.target "_blank"
  $ text $ show address

txLink :: forall a. TxHash -> Maybe TxStatus -> HTML a
txLink hash status = do
  a
    ! A.href (txURL hash)
    ! className "AddressURL"
    ! A.target "_blank"
    $ text $ (take 8 $ show hash ) <> "..."
  div $ text case status of
    Nothing -> ""
    Just result -> case result of
      TxPending -> "Pending..."
      TxFailed -> "Failed"
      TxOk -> "Successful"

addressURL :: Address -> String
addressURL (Address address) =
  "https://etherscan.io/address/" <> address

txURL :: TxHash -> String
txURL (TxHash hash) =
  "https://etherscan.io/tx/" <> hash

navigate :: Location -> DOMEvent -> Event
navigate location = Routing <<< Locations.Navigate location

ignoreEvent :: DOMEvent -> Event
ignoreEvent = PreventDefault Nothing

preventingDefault :: Event -> DOMEvent -> Event
preventingDefault next = PreventDefault $ Just next

onClickAction :: Event -> EventHandlers (DOMEvent -> Event)
onClickAction next = onClick $ preventingDefault next

-- | Use where result is expected to be always `Just` due to the app logic,
-- | eg. in internal store lookups
expectResult :: forall a. Maybe a -> a
expectResult a = unsafePartial $ fromJust $ a

module App.View where

import Text.Smolder.HTML hiding (address)

import App.Routing (Location(..))
import App.State (Event(..), State, signerLens)
import App.State.Contracts as Contracts
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Locations as Locations
import App.State.Signers as Signers
import Data.Array (fromFoldable)
import Data.Either (Either(..))
import Data.Lens ((^.))
import Data.Map (toUnfoldable, values)
import Data.Maybe (Maybe(..), fromJust, isJust, maybe)
import Data.String (drop, length, take, toLower)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.Eth.Contracts (class EthContract, getAddress)
import Lib.Eth.Web3 (TxHash(..), TxStatus(..))
import Lib.SignHash.Proofs.Display (SignerDisplayStatus(..), signerDisplayStatus)
import Lib.SignHash.Proofs.Methods (ProofMethod(..), canonicalName)
import Lib.SignHash.Proofs.Types (ProofState(..), ProofVerification(..))
import Lib.SignHash.Proofs.Values as ProofValues
import Lib.SignHash.Types (Address(..), HashSigner(..))
import Partial.Unsafe (unsafePartial)
import Prelude (discard, show, ($), (-), (<<<), (<>))
import Pux.DOM.Events (DOMEvent, onChange, onClick, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML.Attributes (className, for, id, src, type')
import Text.Smolder.HTML.Attributes as A
import Text.Smolder.Markup (Attribute, EventHandlers, attribute, text, (!), (#!))

foreign import images ::
  { logo :: String
  , ethIcon :: String }

dataQA :: String -> Attribute
dataQA = attribute "data-qa"

view :: State -> HTML Event
view state =
  do
    div ! className "Content" $ do
      div ! className "Header" $ do
        img ! src images.logo
        span ! className "title" $ text "SignHash"

      nav ! className "Navbar" $ do
        ul do
          li $ a ! A.href "#" #! onClick (navigate Sign) $ text "Sign"
          li $ a ! A.href "#" #! onClick (navigate Verify) $ text "Verify"

      viewContent state

      hr
      div ! className "Contracts-info" $ do
        viewContracts state.contracts
      clear

viewContent :: State -> HTML Event
viewContent state@{ location: Verify, file } = do
  viewFileInput "Verify" (isJust file)
  case file of
    Nothing -> empty
    Just loaded -> do
      viewFile loaded
      div $ signerStatus loaded.signer
  where
    signerStatus = case _ of
      Nothing -> sectionHeader "Loading signer..."
      Just (NoSigner) -> sectionHeader "No signers"
      Just (HashSigner address) -> do
        sectionHeader "Signers"
        case state ^. signerLens address of
          Nothing -> div do
            text loading
            hr
          Just value -> div do
            child (Signer address) viewSigner $ value
viewContent state@{ location: Sign, signingTx, myAccount } = do
  viewFileInput "Sign" (isJust state.file)
  case state.file of
    Nothing -> empty
    Just file -> do
      viewFile file
      sectionHeader "Your account"
      case myAccount of
        Contracts.Unavailable -> h4 $ text $ "Please install MetaMask extension"
        Contracts.Locked -> h4 $ text $ "Please unlock MetaMask"
        Contracts.Available address ->
          div ! dataQA "my-id" $ do
            let myDetails = expectResult $ state ^. signerLens address
            child (Signer address) viewSigner myDetails
            case file.result of
              Just fileDetails ->
                case signingTx of
                  Nothing ->
                    a
                      ! A.href "#"
                      ! dataQA "sign"
                      #! onClickAction (SignFile fileDetails.hash)
                      $ do
                        text "Sign it"
                  Just (Left err) ->
                    text $ "Error while issuing transaction"
                  Just (Right hash) -> do
                    text $ "Issued tx "
                    let txStatus = Contracts.viewTxResult hash state.contracts
                    txLink hash txStatus
              Nothing -> empty

viewContracts :: Contracts.State -> HTML Event
viewContracts Contracts.Loading =
  text $ "Loading contract..."
viewContracts (Contracts.Loaded state) = do
  contractLink "SignHash" state.signHash
  br
  contractLink "SignProof" state.signProof
  where
    contractLink :: forall c. EthContract c => String -> c -> HTML Event
    contractLink name contract = do
      span $ text $ name <> ": "
      (addressLink $ getAddress contract)
        ! dataQA ((toLower name) <> "-address")

viewContracts (Contracts.Error err) = do
  div
    ! A.title err
    $ text "Error while loading contract"

viewFileInput :: String -> Boolean -> HTML Event
viewFileInput verb small =
  div do
    label
      ! for "file-upload"
      ! className ("File-upload" <> if small then " small" else "")
      #! onDrop handleNewFiles
      #! onDragOver ignoreEvent
      $ do
        renderIcon "fa-file-o"
        text (verb <> " a file")
        if small then empty else
          div ! className "hint"
          $ text "Click or drag and drop on the page"
    input
      ! id "file-upload"
      ! type' "file"
      #! onChange handleNewFiles
  where
    handleNewFiles ev =
      preventingDefault (FileInput $ FileInputs.newFilesEvent ev) ev

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } = do
  div ! className "Files Section" $ do
    div ! className "row" $ do
      renderRow "Filename" $ text $ meta.name
      renderRow "SHA256" $ maybe (text loading) renderHash result
      renderRow "Size" $ renderSize meta.size

  where
    renderRow label value =
      div ! className "columns attribute four" $ do
        span ! className "header" $ text (label <> ":")
        span ! className "value" $ value

    renderSigner (HashSigner address) = show address
    renderSigner NoSigner = "Not signed"

    renderHash { hash } =
      let visibleOffset = 6
      in a
         ! dataQA "checksum"
         ! A.title hash
         ! A.href "#"
         $ text $ take visibleOffset hash
           <> "..."
           <> drop (length hash - visibleOffset) hash

    renderSize size = text $ show meta.size <> " B"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs, blockie } = do
  div ! className "Signer" $ do
    div ! className "header" $ do
      span ! className "status" $ do
        viewSignerStatus
    viewProofs address proofArray
    clear
  where
    proofStates = fromFoldable $ values proofs

    proofArray :: Array (Tuple ProofMethod ProofState)
    proofArray = toUnfoldable proofs

    viewSignerStatus =
      case signerDisplayStatus proofStates of
        SignerLoading -> renderIcon "fa-circle-o-notch loading"
        SignerVerified -> renderBlockie blockie
        SignerVerificationFailed -> renderIcon "fa-exclamation-circle failed"
        SignerNetworkError -> renderIcon "fa-question-circle-o network-error"

viewProofs ::
  Address
  -> Array (Tuple ProofMethod ProofState)
  -> HTML Signers.Event
viewProofs address proofs =
  div ! className "proofs" $ do
    renderEthProof
    for_ proofs renderProof
  where
    renderProof (Tuple method state) = do
      case state of
        Finished result -> renderFinishedProof method result
        NetworkError -> renderNetworkError method
        Pending -> empty

    renderFinishedProof method Unavailable = empty
    renderFinishedProof method (Unverified error) =
      div
        ! className ("proof " <> "failed")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          span ! dataQA "error" ! A.title (show error)
            $ text $ show method <> " verification failed"

    renderFinishedProof method (Verified proofValue) =
      div
        ! className ("proof " <> "verified")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          a ! A.href (methodHref method proof) ! A.target "_blank" $ text proof
      where
        proof = ProofValues.extract proofValue

    renderNetworkError method =
      div ! className ("proof" <> "network-error") $ do
        methodIcon method
        text $ "Network error while fetching proof"

    renderEthProof =
      div ! className "proof" $ do
        renderEthIcon
        (addressLink address) ! dataQA "proof-details-eth"

    methodIcon GitHub = renderIcon "fa-github"
    methodIcon HTTP = renderIcon "fa-world"

    methodHref GitHub username =
      "https://github.com/" <> username
    methodHref HTTP domain =
      "http://" <> domain

sectionHeader :: forall a. String -> HTML a
sectionHeader msg =
  h4 ! className "Section-header" $ text msg

renderIcon :: forall a. String -> HTML a
renderIcon name = i ! className ("fa fa-lg " <> name) $ text ""

renderEthIcon :: forall a. Html a
renderEthIcon =
  img
  ! className "Icon"
  ! src images.ethIcon

renderBlockie :: forall a. String -> HTML a
renderBlockie blockieSrc =
  img ! className "blockie" ! src blockieSrc

loading :: String
loading = "Loading..."

empty :: forall a. HTML a
empty = text ""

clear :: forall a. HTML a
clear = div ! className "Clear" $ empty

addressLink :: forall a. Address -> HTML a
addressLink address = do
  a
  ! A.href (addressURL address)
  ! className "AddressURL"
  ! A.target "_blank"
  $ text $ show address

txLink :: forall a. TxHash -> Maybe TxStatus -> HTML a
txLink hash status = do
  a
    ! A.href (txURL hash)
    ! className "AddressURL"
    ! A.target "_blank"
    $ text $ (take 8 $ show hash ) <> "..."
  div $ text case status of
    Nothing -> ""
    Just result -> case result of
      TxPending -> "Pending..."
      TxFailed -> "Failed"
      TxOk -> "Successful"

addressURL :: Address -> String
addressURL (Address address) =
  "https://etherscan.io/address/" <> address

txURL :: TxHash -> String
txURL (TxHash hash) =
  "https://etherscan.io/tx/" <> hash

navigate :: Location -> DOMEvent -> Event
navigate location = Routing <<< Locations.Navigate location

ignoreEvent :: DOMEvent -> Event
ignoreEvent = PreventDefault Nothing

preventingDefault :: Event -> DOMEvent -> Event
preventingDefault next = PreventDefault $ Just next

onClickAction :: Event -> EventHandlers (DOMEvent -> Event)
onClickAction next = onClick $ preventingDefault next

-- | Use where result is expected to be always `Just` due to the app logic,
-- | eg. in internal store lookups
expectResult :: forall a. Maybe a -> a
expectResult a = unsafePartial $ fromJust $ a