simplify insertion code (#104)

simplify insertion code (#104)

* simplify insertion code

* restore use of `comp`

avoid instance lookup overhead

-- | 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
  , toUnfoldable
  , toAscUnfoldable
  , delete
  , pop
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  , mapWithKey
  ) where

import Prelude
import Data.Eq (class Eq1)
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.Ord (class Ord1)
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)

-- Internal use
toAscArray :: forall k v. Map k v -> Array (Tuple k v)
toAscArray = toAscUnfoldable

instance eq1Map :: Eq k => Eq1 (Map k) where
  eq1 = eq

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

instance ord1Map :: Ord k => Ord1 (Map k) where
  compare1 = compare

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

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "(fromFoldable " <> show (toAscArray 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)

-- | Look up a value for the specified key
lookup :: forall k v. Ord k => k -> Map k v -> Maybe v
lookup k = go
  where
    comp :: k -> k -> Ordering
    comp = compare

    go Leaf = Nothing
    go (Two left k1 v right) =
      case comp k k1 of
        EQ -> Just v
        LT -> go left
        _  -> go right
    go (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, _  -> go left
            _ , GT -> go right
            _ , _  -> go mid

-- | Look up 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 k = go
  where
    comp :: k -> k -> Ordering
    comp = compare

    go Leaf = Nothing
    go (Two left k1 v1 right) = case comp k k1 of
      EQ -> Just { key: k1, value: v1 }
      GT -> Just $ fromMaybe { key: k1, value: v1 } $ go right
      LT -> go left
    go (Three left k1 v1 mid k2 v2 right) = case comp k k2 of
      EQ -> Just { key: k2, value: v2 }
      GT -> Just $ fromMaybe { key: k2, value: v2 } $ go right
      LT -> go $ Two left k1 v1 mid

-- | Look up 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 k = go
  where
    comp :: k -> k -> Ordering
    comp = compare

    go Leaf = Nothing
    go (Two left k1 v1 right) = case comp k k1 of
      EQ -> findMax left
      GT -> Just $ fromMaybe { key: k1, value: v1 } $ go right
      LT -> go left
    go (Three left k1 v1 mid k2 v2 right) = case comp k k2 of
      EQ -> findMax $ Two left k1 v1 mid
      GT -> Just $ fromMaybe { key: k2, value: v2 } $ go right
      LT -> go $ Two left k1 v1 mid

-- | Look up 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 k = go
  where
    comp :: k -> k -> Ordering
    comp = compare

    go Leaf = Nothing
    go (Two left k1 v1 right) = case comp k k1 of
      EQ -> Just { key: k1, value: v1 }
      LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left
      GT -> go right
    go (Three left k1 v1 mid k2 v2 right) = case comp k k1 of
      EQ -> Just { key: k1, value: v1 }
      LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left
      GT -> go $ Two mid k2 v2 right

-- | Look up 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 k = go
  where
    comp :: k -> k -> Ordering
    comp = compare

    go Leaf = Nothing
    go (Two left k1 v1 right) = case comp k k1 of
      EQ -> findMin right
      LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left
      GT -> go right
    go (Three left k1 v1 mid k2 v2 right) = case comp k k1 of
      EQ -> findMin $ Two mid k2 v2 right
      LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left
      GT -> go $ 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 or replace a key/value pair in a map
insert :: forall k v. Ord k => k -> v -> Map k v -> Map k v
insert k v = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> Map k v -> Map k v
  down ctx Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx (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) left
      _  -> down (Cons (TwoRight left k1 v1) ctx) right
  down ctx (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) left
          GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) mid
          _ , _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) 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 k = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> Map k v -> Maybe (Tuple v (Map k v))
  down = unsafePartial \ctx 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) left
        _   , _  -> down (Cons (TwoRight left k1 v1) ctx) 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) left
        _   , GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) mid
        _   , _ , _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) 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 an unfoldable structure of key/value pairs
toUnfoldable :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v)
toUnfoldable m = unfoldr go (m : Nil) where
  go Nil = Nothing
  go (hd : tl) = case hd of
    Leaf -> go tl
    Two left k v right ->
      Just $ Tuple (Tuple k v) (left : right : tl)
    Three left k1 v1 mid k2 v2 right ->
      Just $ Tuple (Tuple k1 v1) (singleton k2 v2 : left : mid : right : tl)

-- | Convert a map to an unfoldable structure of key/value pairs where the keys are in ascending order
toAscUnfoldable :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v)
toAscUnfoldable m = unfoldr go (m : Nil) where
  go Nil = Nothing
  go (hd : tl) = case hd of
    Leaf -> go tl
    Two Leaf k v Leaf ->
      Just $ Tuple (Tuple k v) tl
    Two Leaf k v right ->
      Just $ Tuple (Tuple k v) (right : tl)
    Two left k v right ->
      go $ left : singleton k v : right : tl
    Three left k1 v1 mid k2 v2 right ->
      go $ left : singleton k1 v1 : mid : singleton k2 v2 : right : tl

-- | 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 (toUnfoldable m1 :: List (Tuple k v))
  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
  , toUnfoldable
  , toAscUnfoldable
  , delete
  , pop
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  , mapWithKey
  ) where

import Prelude
import Data.Eq (class Eq1)
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.Ord (class Ord1)
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)

-- Internal use
toAscArray :: forall k v. Map k v -> Array (Tuple k v)
toAscArray = toAscUnfoldable

instance eq1Map :: Eq k => Eq1 (Map k) where
  eq1 = eq

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

instance ord1Map :: Ord k => Ord1 (Map k) where
  compare1 = compare

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

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "(fromFoldable " <> show (toAscArray 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)

-- | Look up a value for the specified key
lookup :: forall k v. Ord k => k -> Map k v -> Maybe v
lookup k = go
  where
    comp :: k -> k -> Ordering
    comp = compare

    go Leaf = Nothing
    go (Two left k1 v right) =
      case comp k k1 of
        EQ -> Just v
        LT -> go left
        _  -> go right
    go (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, _  -> go left
            _ , GT -> go right
            _ , _  -> go mid

-- | Look up 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 k = go
  where
    comp :: k -> k -> Ordering
    comp = compare

    go Leaf = Nothing
    go (Two left k1 v1 right) = case comp k k1 of
      EQ -> Just { key: k1, value: v1 }
      GT -> Just $ fromMaybe { key: k1, value: v1 } $ go right
      LT -> go left
    go (Three left k1 v1 mid k2 v2 right) = case comp k k2 of
      EQ -> Just { key: k2, value: v2 }
      GT -> Just $ fromMaybe { key: k2, value: v2 } $ go right
      LT -> go $ Two left k1 v1 mid

-- | Look up 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 k = go
  where
    comp :: k -> k -> Ordering
    comp = compare

    go Leaf = Nothing
    go (Two left k1 v1 right) = case comp k k1 of
      EQ -> findMax left
      GT -> Just $ fromMaybe { key: k1, value: v1 } $ go right
      LT -> go left
    go (Three left k1 v1 mid k2 v2 right) = case comp k k2 of
      EQ -> findMax $ Two left k1 v1 mid
      GT -> Just $ fromMaybe { key: k2, value: v2 } $ go right
      LT -> go $ Two left k1 v1 mid

-- | Look up 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 k = go
  where
    comp :: k -> k -> Ordering
    comp = compare

    go Leaf = Nothing
    go (Two left k1 v1 right) = case comp k k1 of
      EQ -> Just { key: k1, value: v1 }
      LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left
      GT -> go right
    go (Three left k1 v1 mid k2 v2 right) = case comp k k1 of
      EQ -> Just { key: k1, value: v1 }
      LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left
      GT -> go $ Two mid k2 v2 right

-- | Look up 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 k = go
  where
    comp :: k -> k -> Ordering
    comp = compare

    go Leaf = Nothing
    go (Two left k1 v1 right) = case comp k k1 of
      EQ -> findMin right
      LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left
      GT -> go right
    go (Three left k1 v1 mid k2 v2 right) = case comp k k1 of
      EQ -> findMin $ Two mid k2 v2 right
      LT -> Just $ fromMaybe { key: k1, value: v1 } $ go left
      GT -> go $ 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 or replace a key/value pair in 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 k = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> Map k v -> Maybe (Tuple v (Map k v))
  down = unsafePartial \ctx 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) left
        _   , _  -> down (Cons (TwoRight left k1 v1) ctx) 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) left
        _   , GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) mid
        _   , _ , _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) 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 an unfoldable structure of key/value pairs
toUnfoldable :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v)
toUnfoldable m = unfoldr go (m : Nil) where
  go Nil = Nothing
  go (hd : tl) = case hd of
    Leaf -> go tl
    Two left k v right ->
      Just $ Tuple (Tuple k v) (left : right : tl)
    Three left k1 v1 mid k2 v2 right ->
      Just $ Tuple (Tuple k1 v1) (singleton k2 v2 : left : mid : right : tl)

-- | Convert a map to an unfoldable structure of key/value pairs where the keys are in ascending order
toAscUnfoldable :: forall f k v. Unfoldable f => Map k v -> f (Tuple k v)
toAscUnfoldable m = unfoldr go (m : Nil) where
  go Nil = Nothing
  go (hd : tl) = case hd of
    Leaf -> go tl
    Two Leaf k v Leaf ->
      Just $ Tuple (Tuple k v) tl
    Two Leaf k v right ->
      Just $ Tuple (Tuple k v) (right : tl)
    Two left k v right ->
      go $ left : singleton k v : right : tl
    Three left k1 v1 mid k2 v2 right ->
      go $ left : singleton k1 v1 : mid : singleton k2 v2 : right : tl

-- | 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 (toUnfoldable m1 :: List (Tuple k v))
  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)


Controls

Controls

module Component.Pong where

import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P

import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Timer (clearInterval, interval, Interval, TIMER)

import Data.Boolean (otherwise)
import Data.Eq ((==))
import Data.Int (ceil)
import Data.Maybe (Maybe(..))
import Data.Semigroup ((<>))
import Graphics.Canvas (CANVAS)
import Halogen (ComponentDSL, ComponentHTML, Component, HalogenEffects, action, lifecycleComponent, liftH, get, modify, subscribe, eventSource_, EventSource)
import Halogen.HTML.Properties (pixels)
import Pong (sendCommand, PongState(..), DirY(..), Move(..), Player(..), PongCommand(..), renderPong, initialPongState)
import Prelude (class Monad, type (~>), Unit, bind, pure, show, void, ($), (<<<))

type State = { pong :: PongState, loop :: Maybe Interval}

initial :: State
initial = {pong: initialPongState, loop: Nothing}
type KeyCode = Number
data Query a = NewGame a | StopGame a | Input KeyCode a | StepGame a

type PongEffects eff = (canvas :: CANVAS , timer :: TIMER, console :: CONSOLE | eff)

game :: forall g eff. (Monad g, Affable (HalogenEffects(PongEffects eff)) g, MonadEff (HalogenEffects(PongEffects eff)) g) => Component State Query g
game = lifecycleComponent {render, eval, initializer: Just (action NewGame), finalizer: Just (action StopGame)}
            where
              render :: State -> ComponentHTML Query
              render {pong} = H.div [] [ H.canvas [ P.id_ canvasName
                                             , E.onKeyDown  (E.input (\ {keyCode} -> Input keyCode))
                                             , P.tabIndex 0
                                             , P.height $ pixels $ ceil canvasSize.h
                                             , P.width
                                               $ pixels
                                               $ ceil canvasSize.w ]
                                        , renderGameInfo pong]

              eval :: Query ~> (ComponentDSL State Query g)
              eval (NewGame a) = do
                s <- get
                liftH <<< liftEff $ log "initialise pong"
                liftH <<< liftEff $ renderPong canvasName s.pong
                subscribe $ stepper
                pure a
              eval (Input keyCode a) =
                case lookupCommand keyCode of
                  Nothing -> pure a
                  Just com -> do
                    modify (\s -> s {pong = sendCommand (com) s.pong})
                    s <- get
                    liftH <<< liftEff $ renderPong canvasName s.pong
                    pure a
              eval (StopGame a) = do
                s <- get
                case s.loop of
                  (Just i) -> do
                    liftH <<< liftEff $ log "clear pong"
                    liftH <<< liftEff $ clearInterval i
                    pure a
                  Nothing -> pure a
                pure a
              eval (StepGame a) = do
                modify (\s -> s { pong = sendCommand Step s.pong })
                s <- get
                liftH <<< liftEff $ renderPong canvasName s.pong
                pure a

lookupCommand :: KeyCode -> Maybe PongCommand
lookupCommand c | c == 83.0 = Just $ MovePlayer { player: One, move: Direction Down}
                | c == 87.0 = Just $ MovePlayer { player: One, move: Direction Up}
                | c == 40.0 = Just $ MovePlayer { player: Two, move: Direction Down}
                | c == 38.0 = Just $ MovePlayer { player: Two, move: Direction Up}
                | otherwise = Nothing
renderGameInfo :: PongState -> ComponentHTML Query
renderGameInfo (PongState {score:{one, two} }) = H.div [] [H.text (show one <> " : " <> show two) ]

canvasName :: String
canvasName = "Foo"

type Dimension = {h :: Number, w :: Number}

canvasSize :: Dimension
canvasSize = {h: 300.0, w: 500.0}

batSize :: Dimension
batSize = {h: 70.0, w: 10.0}

loop :: forall eff . Eff (timer :: TIMER | eff) Unit -> Eff (timer:: TIMER | eff) Unit
loop a = let x = void $ interval 50 a in
  x

stepper ::  forall g eff. (Monad g, Affable (HalogenEffects(PongEffects eff)) g) => EventSource Query g
stepper = eventSource_ loop (pure $ action StepGame)

module Component.Pong where

import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import CSS (a)
import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Timer (clearInterval, interval, Interval, TIMER)
import DOM.HTML.HTMLElement (offsetHeight)
import Data.Boolean (otherwise)
import Data.Int (ceil)
import Data.Maybe (Maybe(..))
import Data.Semigroup ((<>))
import Graphics.Canvas (CANVAS)
import Halogen (ComponentDSL, ComponentHTML, Component, HalogenEffects, action, lifecycleComponent, liftH, get, modify, subscribe, eventSource_, EventSource)
import Halogen.HTML.Properties (pixels)
import Pong (sendCommand, PongState(..), DirY(..), Move(..), Player(..), PongCommand(..), renderPong, initialPongState)
import Prelude (class Monad, type (~>), Unit, bind, pure, show, void, ($), (+), (<<<))

type State = { pong :: PongState, loop :: Maybe Interval}

initial :: State
initial = {pong: initialPongState, loop: Nothing}
type KeyCode = Number
data Query a = NewGame a | StopGame a | Input KeyCode a | StepGame a

type PongEffects eff = (canvas :: CANVAS , timer :: TIMER, console :: CONSOLE | eff)

game :: forall g eff. (Monad g, Affable (HalogenEffects(PongEffects eff)) g, MonadEff (HalogenEffects(PongEffects eff)) g) => Component State Query g
game = lifecycleComponent {render, eval, initializer: Just (action NewGame), finalizer: Just (action StopGame)}
            where
              render :: State -> ComponentHTML Query
              render {pong} = H.div [] [ H.canvas [ P.id_ canvasName
                                             , E.onKeyDown  (E.input (\ {keyCode} -> Input keyCode))
                                             , P.tabIndex 0
                                             , P.height $ pixels $ ceil canvasSize.h
                                             , P.width
                                               $ pixels
                                               $ ceil canvasSize.w ]
                                        , renderGameInfo pong]

              eval :: Query ~> (ComponentDSL State Query g)
              eval (NewGame a) = do
                s <- get
                liftH <<< liftEff $ log "initialise pong"
                liftH <<< liftEff $ renderPong canvasName s.pong
                subscribe $ stepper
                pure a
              eval (Input keyCode a) =
                case lookupCommand keyCode of
                  Nothing -> pure a
                  Just com -> do
                    modify (\s -> s {pong = sendCommand (com) s.pong})
                    s <- get
                    liftH <<< liftEff $ renderPong canvasName s.pong
                    pure a
              eval (StopGame a) = do
                s <- get
                case s.loop of
                  (Just i) -> do
                    liftH <<< liftEff $ log "clear pong"
                    liftH <<< liftEff $ clearInterval i
                    pure a
                  Nothing -> pure a
                pure a
              eval (StepGame a) = do
                modify (\s -> s { pong = sendCommand Step s.pong })
                s <- get
                liftH <<< liftEff $ renderPong canvasName s.pong
                pure a

lookupCommand :: KeyCode -> Maybe PongCommand
lookupCommand c | otherwise = Just $ MovePlayer { player: One, move: Direction Down}

renderGameInfo :: PongState -> ComponentHTML Query
renderGameInfo (PongState {score:{one, two} }) = H.div [] [H.text (show one <> " : " <> show two) ]

canvasName :: String
canvasName = "Foo"

type Dimension = {h :: Number, w :: Number}

canvasSize :: Dimension
canvasSize = {h: 300.0, w: 500.0}

batSize :: Dimension
batSize = {h: 70.0, w: 10.0}

loop :: forall eff . Eff (timer :: TIMER | eff) Unit -> Eff (timer:: TIMER | eff) Unit
loop a = let x = void $ interval 100 a in
  x

stepper ::  forall g eff. (Monad g, Affable (HalogenEffects(PongEffects eff)) g) => EventSource Query g
stepper = eventSource_ loop (pure $ action StepGame)


added examples to array module documentation (#121)


Fix transposed distinctP arguments

Fix transposed distinctP arguments

The dictionary entry for eq gets passed in first. There was also a
function arity issue with the definition that would quietly fail because
javascript coerces functions to true ( ͡° ͜ʖ ͡°)

module Signal
  ( Signal(..)
  , constant
  , lift
  , applySig
  , merge
  , foldp
  , sampleOn
  , distinct
  , zip
  , runSignal
  , unwrap
  , (<~)
  , (~>)
  , (~)
  ) where

import Control.Monad.Eff
import Data.Function
import Data.Tuple(Tuple(..))

foreign import data Signal :: * -> *

foreign import constant """
  function constant(initial) {
    var subs = [];
    var val = initial;
    var sig = {
      subscribe: function(sub) {
        subs.push(sub);
      },
      get: function() { return val; },
      set: function(newval) {
        val = newval;
        subs.forEach(function(sub) { sub(newval); });
      }
    };
    return sig;
  }""" :: forall a. a -> Signal a

foreign import liftP """
  function liftP(constant, fun, sig) {
    var out = constant(fun(sig.get()));
    sig.subscribe(function(val) { out.set(fun(val)); });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (a -> b) (Signal a) (Signal b)

lift = runFn3 liftP constant

foreign import applySigP """
  function applySigP(constant, fun, sig) {
    var out = constant(fun.get()(sig.get()));
    var produce = function() { out.set(fun.get()(sig.get())); };
    fun.subscribe(produce);
    sig.subscribe(produce);
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal (a -> b)) (Signal a) (Signal b)

applySig = runFn3 applySigP constant

foreign import mergeP """
  function mergeP(constant, sig1, sig2) {
    var out = constant(sig1.get());
    sig1.subscribe(out.set);
    sig2.subscribe(out.set);
    return out;
  }""" :: forall a c. Fn3 (c -> Signal c) (Signal a) (Signal a) (Signal a)

merge = runFn3 mergeP constant

foreign import foldpP """
  function foldpP(constant, fun, seed, sig) {
    var acc = fun(sig.get())(seed);
    var out = constant(acc);
    sig.subscribe(function(val) {
      acc = fun(val)(acc);
      out.set(acc);
    });
    return out;
  }""" :: forall a b c. Fn4 (c -> Signal c) (a -> b -> b) b (Signal a) (Signal b)

foldp = runFn4 foldpP constant

foreign import sampleOnP """
  function sampleOnP(constant, sig1, sig2) {
    var out = constant(sig2.get());
    sig1.subscribe(function() {
      out.set(sig2.get());
    });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal a) (Signal b) (Signal b)

sampleOn = runFn3 sampleOnP constant

foreign import distinctP """
  function distinctP(eq) {
  return function(constant) {
  return function(sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (eq['/='](val)(newval)) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  };};}""" :: forall a c. (Eq a) => (c -> Signal c) -> Signal a -> Signal a

distinct :: forall a. (Eq a) => Signal a -> Signal a
distinct = distinctP constant

foreign import zipP """
  function zipP(Tuple, constant, sig1, sig2) {
    var val1 = sig1.get(), val2 = sig2.get();
    var out = constant(Tuple(val1)(val2));
    sig1.subscribe(function(v) {
      val1 = v;
      out.set(Tuple(val1)(val2));
    });
    sig2.subscribe(function(v) {
      val2 = v;
      out.set(Tuple(val1)(val2));
    });
    return out;
  }""" :: forall a b c. Fn4 (a -> b -> Tuple a b) (c -> Signal c) (Signal a) (Signal b) (Signal (Tuple a b))

zip :: forall a b. Signal a -> Signal b -> Signal (Tuple a b)
zip a b = runFn4 zipP Tuple constant a b

foreign import runSignal """
  function runSignal(sig) {
    return function() {
      sig.subscribe(function(val) {
        val();
      });
      return {};
    };
  }""" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrapP """
  function unwrapP(constant, sig) {
    return function() {
      var out = constant(sig.get()());
      sig.subscribe(function(val) { out.set(val()); });
      return out;
    };
  }""" :: forall e a c. Fn2 (c -> Signal c) (Signal (Eff e a)) (Eff e (Signal a))

unwrap :: forall a e. Signal (Eff e a) -> Eff e (Signal a)
unwrap = runFn2 unwrapP constant

instance functorSignal :: Functor Signal where
  (<$>) = lift

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)

module Signal
  ( Signal(..)
  , constant
  , lift
  , applySig
  , merge
  , foldp
  , sampleOn
  , distinct
  , zip
  , runSignal
  , unwrap
  , (<~)
  , (~>)
  , (~)
  ) where

import Control.Monad.Eff
import Data.Function
import Data.Tuple(Tuple(..))

foreign import data Signal :: * -> *

foreign import constant """
  function constant(initial) {
    var subs = [];
    var val = initial;
    var sig = {
      subscribe: function(sub) {
        subs.push(sub);
      },
      get: function() { return val; },
      set: function(newval) {
        val = newval;
        subs.forEach(function(sub) { sub(newval); });
      }
    };
    return sig;
  }""" :: forall a. a -> Signal a

foreign import liftP """
  function liftP(constant, fun, sig) {
    var out = constant(fun(sig.get()));
    sig.subscribe(function(val) { out.set(fun(val)); });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (a -> b) (Signal a) (Signal b)

lift = runFn3 liftP constant

foreign import applySigP """
  function applySigP(constant, fun, sig) {
    var out = constant(fun.get()(sig.get()));
    var produce = function() { out.set(fun.get()(sig.get())); };
    fun.subscribe(produce);
    sig.subscribe(produce);
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal (a -> b)) (Signal a) (Signal b)

applySig = runFn3 applySigP constant

foreign import mergeP """
  function mergeP(constant, sig1, sig2) {
    var out = constant(sig1.get());
    sig1.subscribe(out.set);
    sig2.subscribe(out.set);
    return out;
  }""" :: forall a c. Fn3 (c -> Signal c) (Signal a) (Signal a) (Signal a)

merge = runFn3 mergeP constant

foreign import foldpP """
  function foldpP(constant, fun, seed, sig) {
    var acc = fun(sig.get())(seed);
    var out = constant(acc);
    sig.subscribe(function(val) {
      acc = fun(val)(acc);
      out.set(acc);
    });
    return out;
  }""" :: forall a b c. Fn4 (c -> Signal c) (a -> b -> b) b (Signal a) (Signal b)

foldp = runFn4 foldpP constant

foreign import sampleOnP """
  function sampleOnP(constant, sig1, sig2) {
    var out = constant(sig2.get());
    sig1.subscribe(function() {
      out.set(sig2.get());
    });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal a) (Signal b) (Signal b)

sampleOn = runFn3 sampleOnP constant

foreign import distinctP """
  function distinctP(constant) {
  return function(eq) {
  return function(sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (eq['/='](val, newval)) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  };};}""" :: forall a c. (Eq a) => (c -> Signal c) -> Signal a -> Signal a

distinct :: forall a. (Eq a) => Signal a -> Signal a
distinct = distinctP constant

foreign import zipP """
  function zipP(Tuple, constant, sig1, sig2) {
    var val1 = sig1.get(), val2 = sig2.get();
    var out = constant(Tuple(val1)(val2));
    sig1.subscribe(function(v) {
      val1 = v;
      out.set(Tuple(val1)(val2));
    });
    sig2.subscribe(function(v) {
      val2 = v;
      out.set(Tuple(val1)(val2));
    });
    return out;
  }""" :: forall a b c. Fn4 (a -> b -> Tuple a b) (c -> Signal c) (Signal a) (Signal b) (Signal (Tuple a b))

zip :: forall a b. Signal a -> Signal b -> Signal (Tuple a b)
zip a b = runFn4 zipP Tuple constant a b

foreign import runSignal """
  function runSignal(sig) {
    return function() {
      sig.subscribe(function(val) {
        val();
      });
      return {};
    };
  }""" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrapP """
  function unwrapP(constant, sig) {
    return function() {
      var out = constant(sig.get()());
      sig.subscribe(function(val) { out.set(val()); });
      return out;
    };
  }""" :: forall e a c. Fn2 (c -> Signal c) (Signal (Eff e a)) (Eff e (Signal a))

unwrap :: forall a e. Signal (Eff e a) -> Eff e (Signal a)
unwrap = runFn2 unwrapP constant

instance functorSignal :: Functor Signal where
  (<$>) = lift

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)


Have query also return Array a instead of Array (F a) like the others

module Database.AnyDB
  ( Query(..)
  , Connection()
  , DB()
  , ConnectionInfo(..)
  , ConnectionString()
  , PgConnectionInfo()
  , Sqlite3ConnectionInfo()
  , mkConnectionString
  , connect
  , close
  , execute, execute_
  , query, query_
  , queryValue, queryValue_
  , queryOne, queryOne_
  , withConnection
  ) where

import Prelude
import Control.Alt
import Control.Monad.Eff
import Control.Monad.Trans
import Data.Either
import Data.Array
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Control.Monad.Aff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception(Error(), error)
import Control.Monad.Error.Class (throwError)
import Data.Traversable (sequence)

import Database.AnyDB.SqlValue

newtype Query a = Query String

instance eqQuery :: Eq (Query a) where
  eq (Query a) (Query b) = a == b
instance showQuery :: Show (Query a) where
  show (Query n) = n

foreign import data Connection :: *

foreign import data DB :: !

type ConnectionString = String

type PgConnectionInfo =
  { host :: String
  , db :: String
  , port :: Int
  , user :: String
  , password :: String
  }

type Sqlite3ConnectionInfo =
  { filename :: String
  , memory :: Boolean}

data ConnectionInfo = Postgres PgConnectionInfo
                    | Sqlite3 Sqlite3ConnectionInfo

mkConnectionString :: ConnectionInfo -> ConnectionString
mkConnectionString (Postgres ci) = "postgres://"
                                    <> ci.user <> ":"
                                    <> ci.password <> "@"
                                    <> ci.host <> ":"
                                    <> show ci.port <> "/"
                                    <> ci.db
mkConnectionString (Sqlite3  ci) = "sqlite3://" <> if (ci.memory) then ":memory:" else ci.filename

-- | Makes a connection to the database.
connect :: forall eff. ConnectionInfo -> Aff (db :: DB | eff) Connection
connect = connect_ <<< mkConnectionString

-- | Runs a query and returns nothing.
execute :: forall eff a. Query a -> Array SqlValue -> Connection -> Aff (db :: DB | eff) Unit
execute (Query sql) params con = void $ runQuery sql params con

-- | Runs a query and returns nothing
execute_ :: forall eff a. Query a -> Connection -> Aff (db :: DB | eff) Unit
execute_ (Query sql) con = void $ runQuery_ sql con

-- | Runs a query and returns all results.
query :: forall eff a. (IsForeign a) =>
         Query a -> Array SqlValue -> Connection -> Aff (db :: DB | eff) (Array a)
query (Query sql) params con = do
  rows <- runQuery sql params con
  either liftError pure (sequence $ read <$> rows)

-- | Just like `query` but does not make any param replacement
query_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) (Array a)
query_ (Query sql) con = do
  rows <- runQuery_ sql con
  either liftError pure (sequence $ read <$> rows)

-- | Runs a query and returns the first row, if any
queryOne :: forall eff a. (IsForeign a) =>
            Query a -> Array SqlValue -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryOne (Query sql) params con = do
  rows <- runQuery sql params con
  maybe (pure Nothing) (either liftError (pure <<< Just)) $ read <$> (rows !! 0)

-- | Just like `queryOne` but does not make any param replacement
queryOne_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryOne_ (Query sql) con = do
  rows <- runQuery_ sql con
  maybe (pure Nothing) (either liftError (pure <<< Just)) $ read <$> (rows !! 0)

-- | Runs a query and returns a single value, if any.
queryValue :: forall eff a. (IsForeign a) =>
              Query a -> Array SqlValue -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryValue (Query sql) params con = do
  val <- runQueryValue sql params con
  pure $ either (const Nothing) Just (read val)

-- | Just like `queryValue` but does not make any param replacement
queryValue_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryValue_ (Query sql) con = do
  val <- runQueryValue_ sql con
  either liftError (pure <<< Just) $ read val

-- | Connects to the database, calls the provided function with the connection
-- | and returns the results.
withConnection :: forall eff a.
                  ConnectionInfo
               -> (Connection -> Aff (db :: DB | eff) a)
               -> Aff (db :: DB | eff) a
withConnection info p = do
  con <- connect info
  finally (p con) $ liftEff (close con)

liftError :: forall e a. ForeignError -> Aff e a
liftError err = throwError $ error (show err)

foreign import connect_ :: forall eff. ConnectionString -> Aff (db :: DB | eff) Connection

foreign import runQuery_ :: forall eff. String -> Connection -> Aff (db :: DB | eff) (Array Foreign)

foreign import runQuery :: forall eff. String -> Array SqlValue -> Connection -> Aff (db :: DB | eff) (Array Foreign)

foreign import runQueryValue_ :: forall eff. String -> Connection -> Aff (db :: DB | eff) Foreign

foreign import runQueryValue :: forall eff. String -> Array SqlValue -> Connection -> Aff (db :: DB | eff) Foreign

foreign import close :: forall eff. Connection -> Eff (db :: DB | eff) Unit

module Database.AnyDB
  ( Query(..)
  , Connection()
  , DB()
  , ConnectionInfo(..)
  , ConnectionString()
  , PgConnectionInfo()
  , Sqlite3ConnectionInfo()
  , mkConnectionString
  , connect
  , close
  , execute, execute_
  , query, query_
  , queryValue, queryValue_
  , queryOne, queryOne_
  , withConnection
  ) where

import Prelude
import Control.Alt
import Control.Monad.Eff
import Control.Monad.Trans
import Data.Either
import Data.Array
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Control.Monad.Aff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception(Error(), error)
import Control.Monad.Error.Class (throwError)
import Data.Traversable (sequence)

import Database.AnyDB.SqlValue

newtype Query a = Query String

instance eqQuery :: Eq (Query a) where
  eq (Query a) (Query b) = a == b
instance showQuery :: Show (Query a) where
  show (Query n) = n

foreign import data Connection :: *

foreign import data DB :: !

type ConnectionString = String

type PgConnectionInfo =
  { host :: String
  , db :: String
  , port :: Int
  , user :: String
  , password :: String
  }

type Sqlite3ConnectionInfo =
  { filename :: String
  , memory :: Boolean}

data ConnectionInfo = Postgres PgConnectionInfo
                    | Sqlite3 Sqlite3ConnectionInfo

mkConnectionString :: ConnectionInfo -> ConnectionString
mkConnectionString (Postgres ci) = "postgres://"
                                    <> ci.user <> ":"
                                    <> ci.password <> "@"
                                    <> ci.host <> ":"
                                    <> show ci.port <> "/"
                                    <> ci.db
mkConnectionString (Sqlite3  ci) = "sqlite3://" <> if (ci.memory) then ":memory:" else ci.filename

-- | Makes a connection to the database.
connect :: forall eff. ConnectionInfo -> Aff (db :: DB | eff) Connection
connect = connect_ <<< mkConnectionString

-- | Runs a query and returns nothing.
execute :: forall eff a. Query a -> Array SqlValue -> Connection -> Aff (db :: DB | eff) Unit
execute (Query sql) params con = void $ runQuery sql params con

-- | Runs a query and returns nothing
execute_ :: forall eff a. Query a -> Connection -> Aff (db :: DB | eff) Unit
execute_ (Query sql) con = void $ runQuery_ sql con

-- | Runs a query and returns all results.
query :: forall eff a. (IsForeign a) =>
         Query a -> Array SqlValue -> Connection -> Aff (db :: DB | eff) (Array (F a))
query (Query sql) params con = do
  rows <- runQuery sql params con
  pure $ read <$> rows

-- | Just like `query` but does not make any param replacement
query_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) (Array a)
query_ (Query sql) con = do
  rows <- runQuery_ sql con
  either liftError pure (sequence $ read <$> rows)

-- | Runs a query and returns the first row, if any
queryOne :: forall eff a. (IsForeign a) =>
            Query a -> Array SqlValue -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryOne (Query sql) params con = do
  rows <- runQuery sql params con
  maybe (pure Nothing) (either liftError (pure <<< Just)) $ read <$> (rows !! 0)

-- | Just like `queryOne` but does not make any param replacement
queryOne_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryOne_ (Query sql) con = do
  rows <- runQuery_ sql con
  maybe (pure Nothing) (either liftError (pure <<< Just)) $ read <$> (rows !! 0)

-- | Runs a query and returns a single value, if any.
queryValue :: forall eff a. (IsForeign a) =>
              Query a -> Array SqlValue -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryValue (Query sql) params con = do
  val <- runQueryValue sql params con
  pure $ either (const Nothing) Just (read val)

-- | Just like `queryValue` but does not make any param replacement
queryValue_ :: forall eff a. (IsForeign a) => Query a -> Connection -> Aff (db :: DB | eff) (Maybe a)
queryValue_ (Query sql) con = do
  val <- runQueryValue_ sql con
  either liftError (pure <<< Just) $ read val

-- | Connects to the database, calls the provided function with the connection
-- | and returns the results.
withConnection :: forall eff a.
                  ConnectionInfo
               -> (Connection -> Aff (db :: DB | eff) a)
               -> Aff (db :: DB | eff) a
withConnection info p = do
  con <- connect info
  finally (p con) $ liftEff (close con)

liftError :: forall e a. ForeignError -> Aff e a
liftError err = throwError $ error (show err)

foreign import connect_ :: forall eff. ConnectionString -> Aff (db :: DB | eff) Connection

foreign import runQuery_ :: forall eff. String -> Connection -> Aff (db :: DB | eff) (Array Foreign)

foreign import runQuery :: forall eff. String -> Array SqlValue -> Connection -> Aff (db :: DB | eff) (Array Foreign)

foreign import runQueryValue_ :: forall eff. String -> Connection -> Aff (db :: DB | eff) Foreign

foreign import runQueryValue :: forall eff. String -> Array SqlValue -> Connection -> Aff (db :: DB | eff) Foreign

foreign import close :: forall eff. Connection -> Eff (db :: DB | eff) Unit


Added function to determine whether a coordinate is valid

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\e -> (Tuple e.x e.y) == coordinate) squares

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex grid.squares from)
      toIndex = fromJust (getCoordinateIndex grid.squares to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  return unit

renderPiece :: forall e.
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: square.rx + 0.5 * renderSize,
                       y: square.ry + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          case isOnSquare square (toNumber ux) (toNumber uy) of
            true -> do
              setLineWidth highlightWidth ctx
              strokePath ctx $ arc ctx arcPiece
              return unit
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events (unsafeEventNumberProp)
import Data.DOM.Simple.Window
import Data.Int (even, odd, toNumber)
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  let color = if player == playerOne
              then colorPlayerOne
              else colorPlayerTwo
  in { player: player, color: color, king: false }

createGrid :: Tuple Number Number -> Int -> Int -> Int -> Grid
createGrid (Tuple ox oy) width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { ox: ox, oy: oy, x: x, y: y, rx: rx, ry: ry, color: color, piece: piece }

createState :: Tuple Number Number -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid: (createGrid offset width height layers),
    currentPlayer: playerOne }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

getCoordinateIndex :: Array Square -> Coordinate -> Maybe Int
getCoordinateIndex squares coordinate = findIndex (\e -> (Tuple e.x e.y) == coordinate) squares

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  return (Tuple (x + i) (y + j))

isOnSquare :: Square -> Number -> Number -> Boolean
isOnSquare square x y =
  let vx = square.rx + square.ox
      vy = square.ry + square.oy
  in vx < x && x < vx + renderSize && vy < y && y < vy + renderSize

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid = grid { squares = newSquares }
    where
      fromIndex = fromJust (getCoordinateIndex grid.squares from)
      toIndex = fromJust (getCoordinateIndex grid.squares to)
      originalSquare = fromJust (grid.squares !! fromIndex)
      afterMove = fromJust (modifyAt toIndex (setPiece originalSquare.piece) grid.squares)
      newSquares = fromJust (modifyAt fromIndex (setPiece Nothing) afterMove)

renderSquare :: forall e.
                  Context2D ->
                  Maybe DOMEvent ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx event _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: square.rx, y: square.ry, w: renderSize, h: renderSize }
  return unit

renderPiece :: forall e.
                 Context2D ->
                 Maybe DOMEvent ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece ctx event _ square =
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: square.rx + 0.5 * renderSize,
                       y: square.ry + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      case event of
        Nothing -> return unit
        Just e -> do
          ux <- unsafeEventNumberProp "clientX" e
          uy <- unsafeEventNumberProp "clientY" e
          case isOnSquare square (toNumber ux) (toNumber uy) of
            true -> do
              setLineWidth highlightWidth ctx
              strokePath ctx $ arc ctx arcPiece
              return unit
            false -> return unit
          return unit
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle "black" ctx
  strokeRect ctx border
  return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Maybe DOMEvent ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st event = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx event) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece ctx event) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  return unit

renderPage :: forall s e.
                STRef s State ->
                Maybe DOMEvent ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st event = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st event
      return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (\e -> renderPage st (Just e)) canvas
      renderPage st Nothing
      return unit
    _ -> return unit


splitRegex - move to top level

splitRegex - move to top level

module Routing.Parser (
  parse
  ) where

import Control.MonadPlus (guard)
import Data.Array as A
import Data.Either (fromRight)
import Data.List (fromFoldable, List)
import Data.Map as M
import Data.Maybe (Maybe, fromMaybe)
import Data.String as S
import Data.String.Regex (Regex, regex, split) as R
import Data.String.Regex.Flags (noFlags) as R
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)
import Prelude (map, discard, (>>>), ($), (<<<), (==), (<*>), (<$>), (<=))
import Routing.Types (Route, RoutePart(..))

-- | Parse part of hash. Will return `Query (Map String String)` for query
-- | i.e. `"?foo=bar&bar=baz"` -->
-- |     `Query (fromList [Tuple "foo" "bar", Tuple "bar" "baz"])`
parsePart :: String -> RoutePart
parsePart str = fromMaybe (Path str) do
  guard $ S.take 1 str == "?"
  map (Query <<< M.fromFoldable)
    $ traverse part2tuple parts
  where
  parts :: List String
  parts = fromFoldable $ S.split (S.Pattern "&") $ S.drop 1 str

  part2tuple :: String -> Maybe (Tuple String String)
  part2tuple input = do
    let keyVal = S.split (S.Pattern "=") input
    guard $ A.length keyVal <= 2
    Tuple <$> (A.head keyVal) <*> (keyVal A.!! 1)

splitRegex :: R.Regex
splitRegex = unsafePartial fromRight $ R.regex "\\/|(?=\\?)" R.noFlags

-- | Parse hash string to `Route` with `decoder` function
-- | applied to every hash part (usually `decodeURIComponent`)
parse :: (String -> String) -> String -> Route
parse decoder hash =
  map ( decoder >>> parsePart ) $ fromFoldable (R.split splitRegex hash)

module Routing.Parser (
  parse
  ) where

import Data.Array as A
import Data.Map as M
import Data.String as S
import Control.MonadPlus (guard)
import Data.Either (fromRight)
import Data.List (fromFoldable, List)
import Data.Maybe (Maybe, fromMaybe)
import Data.String.Regex (regex, split) as R
import Data.String.Regex.Flags (noFlags) as R
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)
import Prelude (map, discard, (>>>), ($), (<<<), (==), (<*>), (<$>), (<=))
import Routing.Types (Route, RoutePart(..))

-- | Parse part of hash. Will return `Query (Map String String)` for query
-- | i.e. `"?foo=bar&bar=baz"` -->
-- |     `Query (fromList [Tuple "foo" "bar", Tuple "bar" "baz"])`
parsePart :: String -> RoutePart
parsePart str = fromMaybe (Path str) do
  guard $ S.take 1 str == "?"
  map (Query <<< M.fromFoldable)
    $ traverse part2tuple parts
  where
  parts :: List String
  parts = fromFoldable $ S.split (S.Pattern "&") $ S.drop 1 str

  part2tuple :: String -> Maybe (Tuple String String)
  part2tuple input = do
    let keyVal = S.split (S.Pattern "=") input
    guard $ A.length keyVal <= 2
    Tuple <$> (A.head keyVal) <*> (keyVal A.!! 1)

-- | Parse hash string to `Route` with `decoder` function
-- | applied to every hash part (usually `decodeURIComponent`)
parse :: (String -> String) -> String -> Route
parse decoder hash =
  map ( decoder >>> parsePart ) $ fromFoldable (R.split (unsafePartial fromRight $ R.regex "\\/|(?=\\?)" R.noFlags) hash)


Added export for contentWindow

Added export for contentWindow

module DOM.HTML.HTMLIFrameElement
  ( src
  , setSrc
  , srcdoc
  , setSrcdoc
  , name
  , setName
  , width
  , setWidth
  , height
  , setHeight
  , contentDocument
  , contentWindow
  ) where

import Prelude

import Control.Monad.Eff (Eff)

import Data.Maybe (Maybe)
import Data.Nullable (Nullable, toMaybe)

import DOM (DOM)
import DOM.HTML.Types (Window, HTMLIFrameElement)
import DOM.Node.Types (Document)

foreign import src :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) String
foreign import setSrc :: forall eff. String -> HTMLIFrameElement -> Eff (dom :: DOM | eff) Unit

foreign import srcdoc :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) String
foreign import setSrcdoc :: forall eff. String -> HTMLIFrameElement -> Eff (dom :: DOM | eff) Unit

foreign import name :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) String
foreign import setName :: forall eff. String -> HTMLIFrameElement -> Eff (dom :: DOM | eff) Unit

--   [PutForwards=value] readonly attribute DOMSettableTokenList sandbox;

foreign import width :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) String
foreign import setWidth :: forall eff. String -> HTMLIFrameElement -> Eff (dom :: DOM | eff) Unit

foreign import height :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) String
foreign import setHeight :: forall eff. String -> HTMLIFrameElement -> Eff (dom :: DOM | eff) Unit

foreign import _contentDocument :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) (Nullable Document)
foreign import _contentWindow :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) (Nullable Window)

contentDocument :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) (Maybe Document)
contentDocument = map toMaybe <<< _contentDocument

contentWindow :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) (Maybe Window)
contentWindow = map toMaybe <<< _contentWindow

module DOM.HTML.HTMLIFrameElement
  ( src
  , setSrc
  , srcdoc
  , setSrcdoc
  , name
  , setName
  , width
  , setWidth
  , height
  , setHeight
  , contentDocument
  ) where

import Prelude

import Control.Monad.Eff (Eff)

import Data.Maybe (Maybe)
import Data.Nullable (Nullable, toMaybe)

import DOM (DOM)
import DOM.HTML.Types (Window, HTMLIFrameElement)
import DOM.Node.Types (Document)

foreign import src :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) String
foreign import setSrc :: forall eff. String -> HTMLIFrameElement -> Eff (dom :: DOM | eff) Unit

foreign import srcdoc :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) String
foreign import setSrcdoc :: forall eff. String -> HTMLIFrameElement -> Eff (dom :: DOM | eff) Unit

foreign import name :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) String
foreign import setName :: forall eff. String -> HTMLIFrameElement -> Eff (dom :: DOM | eff) Unit

--   [PutForwards=value] readonly attribute DOMSettableTokenList sandbox;

foreign import width :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) String
foreign import setWidth :: forall eff. String -> HTMLIFrameElement -> Eff (dom :: DOM | eff) Unit

foreign import height :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) String
foreign import setHeight :: forall eff. String -> HTMLIFrameElement -> Eff (dom :: DOM | eff) Unit

foreign import _contentDocument :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) (Nullable Document)
foreign import _contentWindow :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) (Nullable Window)

contentDocument :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) (Maybe Document)
contentDocument = map toMaybe <<< _contentDocument

contentWindow :: forall eff. HTMLIFrameElement -> Eff (dom :: DOM | eff) (Maybe Window)
contentWindow = map toMaybe <<< _contentWindow


Addressed https://github.com/slamdata/purescript-affjax/issues/5

module Network.HTTP.Affjax.Response
  ( ResponseType(..), responseTypeToString
  , ResponseContent()
  , Respondable, responseType, fromResponse
  ) where

import Prelude
import Data.Either (Either(..))
import Data.Foreign (Foreign(), F(), readString, unsafeReadTagged)
import DOM.File.Types (Blob())
import DOM.Node.Types (Document())
import DOM.XHR.Types (FormData())
import qualified Data.ArrayBuffer.Types as A

-- | Valid response types for an AJAX request. This is used to determine the
-- | `ResponseContent` type for a request. The `a` type variable is a phantom
-- | type used to associate the `ResponseType` with a particular instance of
-- | `Respondable`.
data ResponseType a
  = ArrayBufferResponse
  | BlobResponse
  | DocumentResponse
  | JSONResponse
  | StringResponse

instance eqResponseType :: Eq (ResponseType a) where
  eq ArrayBufferResponse ArrayBufferResponse = true
  eq BlobResponse        BlobResponse        = true
  eq DocumentResponse    DocumentResponse    = true
  eq JSONResponse        JSONResponse        = true
  eq StringResponse      StringResponse      = true
  eq _ _ = false

instance showResponseType :: Show (ResponseType a) where
  show ArrayBufferResponse = "ArrayBufferResponse"
  show BlobResponse = "BlobResponse"
  show DocumentResponse = "DocumentResponse"
  show JSONResponse = "JSONResponse"
  show StringResponse = "StringResponse"

responseTypeToString :: forall a. (ResponseType a) -> String
responseTypeToString ArrayBufferResponse = "arraybuffer"
responseTypeToString BlobResponse = "blob"
responseTypeToString DocumentResponse = "document"
responseTypeToString JSONResponse = "text" -- IE doesn't support "json" responseType
responseTypeToString StringResponse = "text"

-- | Type representing content types that be received from an XHR request
-- | (Blob, Document, JSON, String).
type ResponseContent = Foreign

class Respondable a where
  responseType :: ResponseType a
  fromResponse :: ResponseContent -> F a

instance responsableBlob :: Respondable Blob where
  responseType = BlobResponse
  fromResponse = unsafeReadTagged "Blob"

instance responsableDocument :: Respondable Document where
  responseType = DocumentResponse
  fromResponse = unsafeReadTagged "Document"

instance responsableJSON :: Respondable Foreign where
  responseType = JSONResponse
  fromResponse = Right

instance responsableString :: Respondable String where
  responseType = StringResponse
  fromResponse = readString

instance responsableUnit :: Respondable Unit where
  responseType = StringResponse
  fromResponse = const (Right unit)

instance responsableArrayBuffer :: Respondable A.ArrayBuffer where
  responseType = ArrayBufferResponse
  fromResponse = unsafeReadTagged "ArrayBuffer"


Unused

Unused

Original commit 48ad3b158bf60a13853ac1061474444e9ca22c6d

module Doc
    ( Doc
    , Renderer
    , Transforms
    , getTopLevel
    , getClasses
    , getClass
    , getUnions
    , getUnionNames
    , lookupName
    , lookupClassName
    , lookupUnionName
    , string
    , line
    , blank
    , indent
    -- Build Doc Unit with monad syntax, then render to string
    , runDoc
    , runRenderer
    , getTypeNameForUnion
    ) where

import IR
import IRGraph
import Prelude

import Control.Monad.RWS (RWS, evalRWS, asks, gets, modify, tell)
import Data.Foldable (for_, intercalate, sequence_)
import Data.List (List)
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe, fromMaybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as String
import Data.Tuple (Tuple(..), snd)

type Renderer =
    { name :: String
    , extension :: String
    , aceMode :: String
    , doc :: Doc Unit
    , transforms :: Transforms
    }

type Transforms =
    { nameForClass :: IRClassData -> String
    , unionName :: List String -> String
    , unionPredicate :: IRType -> Maybe (Set IRType)
    , nextName :: String -> String
    , forbiddenNames :: Array String
    }

type DocState = { indent :: Int }

type DocEnv =
    { graph :: IRGraph
    , classNames :: Map Int String
    , unionNames :: Map (Set IRType) String
    , unions :: List (Set IRType)
    }

newtype Doc a = Doc (RWS DocEnv String DocState a)

derive newtype instance functorDoc :: Functor Doc
derive newtype instance applyDoc :: Apply Doc
derive newtype instance applicativeDoc :: Applicative Doc
derive newtype instance bindDoc :: Bind Doc
derive newtype instance monadDoc :: Monad Doc

runRenderer :: Renderer -> IRGraph -> String
runRenderer { doc, transforms } = runDoc doc transforms

runDoc :: forall a. Doc a -> Transforms -> IRGraph -> String
runDoc (Doc w) t graph =
    let classes = classesInGraph graph
        forbidden = S.fromFoldable t.forbiddenNames
        classNames = transformNames t.nameForClass t.nextName forbidden classes
        unions = L.fromFoldable $ filterTypes t.unionPredicate graph
        forbiddenForUnions = S.union forbidden $ S.fromFoldable $ M.values classNames
        nameForUnion s = t.unionName $ map (typeNameForUnion graph) $ L.sort $ L.fromFoldable s
        unionNames = transformNames nameForUnion t.nextName forbiddenForUnions $ map (\s -> Tuple s s) unions
    in
        evalRWS w { graph, classNames, unionNames, unions } { indent: 0 } # snd

typeNameForUnion :: IRGraph -> IRType -> String
typeNameForUnion graph = case _ of
    IRNothing -> "nothing"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion graph a <> "_array"
    IRClass i ->
        let IRClassData { names } = getClassFromGraph graph i
        in
            combineNames names
    IRMap t -> typeNameForUnion graph t <> "_map"
    IRUnion _ -> "union"

getTypeNameForUnion :: IRType -> Doc String
getTypeNameForUnion typ = do
  g <- getGraph
  pure $ typeNameForUnion g typ

getGraph :: Doc IRGraph
getGraph = Doc (asks _.graph)

getTopLevel :: Doc IRType
getTopLevel = do
    IRGraph { toplevel } <- getGraph
    pure toplevel

getClassNames :: Doc (Map Int String)
getClassNames = Doc (asks _.classNames)

getUnions :: Doc (List (Set IRType))
getUnions = Doc (asks _.unions)

getUnionNames :: Doc (Map (Set IRType) String)
getUnionNames = Doc (asks _.unionNames)

getClasses :: Doc (L.List (Tuple Int IRClassData))
getClasses = classesInGraph <$> getGraph

getClass :: Int -> Doc IRClassData
getClass i = do
  graph <- getGraph
  pure $ getClassFromGraph graph i

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> Doc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: Set IRType -> Doc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

-- Given a potentially multi-line string, render each line at the current indent level
line :: String -> Doc Unit
line s = do
    indent <- Doc (gets _.indent)
    let whitespace = times "\t" indent
    let lines = String.split (String.Pattern "\n") s
    for_ lines \l -> do
        string whitespace
        string l
        string "\n"

-- Cannot make this work any other way!
times :: String -> Int -> String
times s n | n < 1 = ""
times s 1 = s
times s n = s <> times s (n - 1)

string :: String -> Doc Unit
string = Doc <<< tell

blank :: Doc Unit
blank = string "\n"

indent :: forall a. Doc a -> Doc a
indent doc = do
    Doc $ modify (\s -> { indent: s.indent + 1 })
    a <- doc
    Doc $ modify (\s -> { indent: s.indent - 1 })
    pure a

module Doc
    ( Doc
    , Renderer
    , Transforms
    , getTopLevel
    , getClasses
    , getClass
    , getClassNames
    , getUnions
    , getUnionNames
    , lookupName
    , lookupClassName
    , lookupUnionName
    , string
    , line
    , blank
    , indent
    -- Build Doc Unit with monad syntax, then render to string
    , runDoc
    , runRenderer
    , getTypeNameForUnion
    ) where

import IR
import IRGraph
import Prelude

import Control.Monad.RWS (RWS, evalRWS, asks, gets, modify, tell)
import Data.Foldable (for_, intercalate, sequence_)
import Data.List (List)
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe, fromMaybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as String
import Data.Tuple (Tuple(..), snd)

type Renderer =
    { name :: String
    , extension :: String
    , aceMode :: String
    , doc :: Doc Unit
    , transforms :: Transforms
    }

type Transforms =
    { nameForClass :: IRClassData -> String
    , unionName :: List String -> String
    , unionPredicate :: IRType -> Maybe (Set IRType)
    , nextName :: String -> String
    , forbiddenNames :: Array String
    }

type DocState = { indent :: Int }

type DocEnv =
    { graph :: IRGraph
    , classNames :: Map Int String
    , unionNames :: Map (Set IRType) String
    , unions :: List (Set IRType)
    }

newtype Doc a = Doc (RWS DocEnv String DocState a)

derive newtype instance functorDoc :: Functor Doc
derive newtype instance applyDoc :: Apply Doc
derive newtype instance applicativeDoc :: Applicative Doc
derive newtype instance bindDoc :: Bind Doc
derive newtype instance monadDoc :: Monad Doc

runRenderer :: Renderer -> IRGraph -> String
runRenderer { doc, transforms } = runDoc doc transforms

runDoc :: forall a. Doc a -> Transforms -> IRGraph -> String
runDoc (Doc w) t graph =
    let classes = classesInGraph graph
        forbidden = S.fromFoldable t.forbiddenNames
        classNames = transformNames t.nameForClass t.nextName forbidden classes
        unions = L.fromFoldable $ filterTypes t.unionPredicate graph
        forbiddenForUnions = S.union forbidden $ S.fromFoldable $ M.values classNames
        nameForUnion s = t.unionName $ map (typeNameForUnion graph) $ L.sort $ L.fromFoldable s
        unionNames = transformNames nameForUnion t.nextName forbiddenForUnions $ map (\s -> Tuple s s) unions
    in
        evalRWS w { graph, classNames, unionNames, unions } { indent: 0 } # snd

typeNameForUnion :: IRGraph -> IRType -> String
typeNameForUnion graph = case _ of
    IRNothing -> "nothing"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion graph a <> "_array"
    IRClass i ->
        let IRClassData { names } = getClassFromGraph graph i
        in
            combineNames names
    IRMap t -> typeNameForUnion graph t <> "_map"
    IRUnion _ -> "union"

getTypeNameForUnion :: IRType -> Doc String
getTypeNameForUnion typ = do
  g <- getGraph
  pure $ typeNameForUnion g typ

getGraph :: Doc IRGraph
getGraph = Doc (asks _.graph)

getTopLevel :: Doc IRType
getTopLevel = do
    IRGraph { toplevel } <- getGraph
    pure toplevel

getClassNames :: Doc (Map Int String)
getClassNames = Doc (asks _.classNames)

getUnions :: Doc (List (Set IRType))
getUnions = Doc (asks _.unions)

getUnionNames :: Doc (Map (Set IRType) String)
getUnionNames = Doc (asks _.unionNames)

getClasses :: Doc (L.List (Tuple Int IRClassData))
getClasses = classesInGraph <$> getGraph

getClass :: Int -> Doc IRClassData
getClass i = do
  graph <- getGraph
  pure $ getClassFromGraph graph i

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> Doc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: Set IRType -> Doc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

-- Given a potentially multi-line string, render each line at the current indent level
line :: String -> Doc Unit
line s = do
    indent <- Doc (gets _.indent)
    let whitespace = times "\t" indent
    let lines = String.split (String.Pattern "\n") s
    for_ lines \l -> do
        string whitespace
        string l
        string "\n"

-- Cannot make this work any other way!
times :: String -> Int -> String
times s n | n < 1 = ""
times s 1 = s
times s n = s <> times s (n - 1)

string :: String -> Doc Unit
string = Doc <<< tell

blank :: Doc Unit
blank = string "\n"

indent :: forall a. Doc a -> Doc a
indent doc = do
    Doc $ modify (\s -> { indent: s.indent + 1 })
    a <- doc
    Doc $ modify (\s -> { indent: s.indent - 1 })
    pure a