Use iterators to implement groupBy

Use iterators to implement groupBy

Refs #71, improves performance of groupBy.

-- | Helper functions for working with immutable Javascript arrays.
-- |
-- | _Note_: Depending on your use-case, you may prefer to use `Data.List` or
-- | `Data.Sequence` instead, which might give better performance for certain
-- | use cases. This module is useful when integrating with JavaScript libraries
-- | which use arrays, but immutable arrays are not a practical data structure
-- | for many use cases due to their poor asymptotics.
-- |
-- | In addition to the functions in this module, Arrays have a number of
-- | useful instances:
-- |
-- | * `Functor`, which provides `map :: forall a b. (a -> b) -> Array a ->
-- |   Array b`
-- | * `Apply`, which provides `(<*>) :: forall a b. Array (a -> b) -> Array a
-- |   -> Array b`. This function works a bit like a Cartesian product; the
-- |   result array is constructed by applying each function in the first
-- |   array to each value in the second, so that the result array ends up with
-- |   a length equal to the product of the two arguments' lengths.
-- | * `Bind`, which provides `(>>=) :: forall a b. (a -> Array b) -> Array a
-- |   -> Array b` (this is the same as `concatMap`).
-- | * `Semigroup`, which provides `(<>) :: forall a. Array a -> Array a ->
-- |   Array a`, for concatenating arrays.
-- | * `Foldable`, which provides a slew of functions for *folding* (also known
-- |   as *reducing*) arrays down to one value. For example,
-- |   `Data.Foldable.or` tests whether an array of `Boolean` values contains
-- |   at least one `true` value.
-- | * `Traversable`, which provides the PureScript version of a for-loop,
-- |   allowing you to iterate over an array and accumulate effects.
-- |
module Data.Array
  ( fromFoldable
  , toUnfoldable
  , singleton
  , (..), range
  , replicate
  , some
  , many

  , null
  , length

  , (:), cons
  , snoc
  , insert
  , insertBy

  , head
  , last
  , tail
  , init
  , uncons
  , unsnoc

  , (!!), index
  , elemIndex
  , elemLastIndex
  , findIndex
  , findLastIndex
  , insertAt
  , deleteAt
  , updateAt
  , modifyAt
  , alterAt

  , reverse
  , concat
  , concatMap
  , filter
  , partition
  , filterA
  , filterM
  , mapMaybe
  , catMaybes
  , mapWithIndex

  , sort
  , sortBy

  , slice
  , take
  , takeWhile
  , drop
  , dropWhile
  , span
  , group
  , group'
  , groupBy

  , nub
  , nubBy
  , union
  , unionBy
  , delete
  , deleteBy

  , (\\), difference
  , intersect
  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex

  , module Exports
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy, defer)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM2)
import Control.Monad.ST (pureST)
import Data.Array.ST (unsafeFreeze, emptySTArray, pushSTArray)
import Data.Array.ST.Iterator (iterator, iterate, pushWhile)
import Data.Foldable (class Foldable, foldl, foldr)
import Data.Foldable (foldl, foldr, foldMap, fold, intercalate, elem, notElem, find, findMap, any, all) as Exports
import Data.Maybe (Maybe(..), maybe, isJust, fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Traversable (scanl, scanr) as Exports
import Data.Traversable (sequence, traverse)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable, unfoldr)
import Partial.Unsafe (unsafePartial)

-- | Convert an `Array` into an `Unfoldable` structure.
toUnfoldable :: forall f a. Unfoldable f => Array a -> f a
toUnfoldable xs = unfoldr f 0
  where
  len = length xs
  f i
    | i < len   = Just (Tuple (unsafePartial (unsafeIndex xs i)) (i+1))
    | otherwise = Nothing

-- | Convert a `Foldable` structure into an `Array`.
fromFoldable :: forall f a. Foldable f => f a -> Array a
fromFoldable = fromFoldableImpl foldr

foreign import fromFoldableImpl
  :: forall f a
   . (forall b. (a -> b -> b) -> b -> f a -> b)
  -> f a
  -> Array a

-- | Create an array of one element
singleton :: forall a. a -> Array a
singleton a = [a]

-- | Create an array containing a range of integers, including both endpoints.
foreign import range :: Int -> Int -> Array Int

-- | Create an array containing a value repeated the specified number of times.
foreign import replicate :: forall a. Int -> a -> Array a

-- | An infix synonym for `range`.
infix 8 range as ..

-- | Attempt a computation multiple times, requiring at least one success.
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
some :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
some v = (:) <$> v <*> defer (\_ -> many v)

-- | Attempt a computation multiple times, returning as many successful results
-- | as possible (possibly zero).
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
many :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
many v = some v <|> pure []

--------------------------------------------------------------------------------
-- Array size ------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test whether an array is empty.
null :: forall a. Array a -> Boolean
null xs = length xs == 0

-- | Get the number of elements in an array.
foreign import length :: forall a. Array a -> Int

--------------------------------------------------------------------------------
-- Extending arrays ------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Attaches an element to the front of an array, creating a new array.
-- |
-- | ```purescript
-- | cons 1 [2, 3, 4] = [1, 2, 3, 4]
-- | ```
-- |
-- | Note, the running time of this function is `O(n)`.
foreign import cons :: forall a. a -> Array a -> Array a

-- | An infix alias for `cons`.
-- |
-- | Note, the running time of this function is `O(n)`.
infixr 6 cons as :

-- | Append an element to the end of an array, creating a new array.
foreign import snoc :: forall a. Array a -> a -> Array a

-- | Insert an element into a sorted array.
insert :: forall a. Ord a => a -> Array a -> Array a
insert = insertBy compare

-- | Insert an element into a sorted array, using the specified function to
-- | determine the ordering of elements.
insertBy :: forall a. (a -> a -> Ordering) -> a -> Array a -> Array a
insertBy cmp x ys =
  let i = maybe 0 (_ + 1) (findLastIndex (\y -> cmp x y == GT) ys)
  in unsafePartial (fromJust (insertAt i x ys))

--------------------------------------------------------------------------------
-- Non-indexed reads -----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Get the first element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
head :: forall a. Array a -> Maybe a
head xs = xs !! 0

-- | Get the last element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
last :: forall a. Array a -> Maybe a
last xs = xs !! (length xs - 1)

-- | Get all but the first element of an array, creating a new array, or
-- | `Nothing` if the array is empty
-- |
-- | Running time: `O(n)` where `n` is the length of the array
tail :: forall a. Array a -> Maybe (Array a)
tail = uncons' (const Nothing) (\_ xs -> Just xs)

-- | Get all but the last element of an array, creating a new array, or
-- | `Nothing` if the array is empty.
-- |
-- | Running time: `O(n)` where `n` is the length of the array
init :: forall a. Array a -> Maybe (Array a)
init xs
  | null xs = Nothing
  | otherwise = Just (slice zero (length xs - one) xs)

-- | Break an array into its first element and remaining elements.
-- |
-- | Using `uncons` provides a way of writing code that would use cons patterns
-- | in Haskell or pre-PureScript 0.7:
-- | ``` purescript
-- | f (x : xs) = something
-- | f [] = somethingElse
-- | ```
-- | Becomes:
-- | ``` purescript
-- | f arr = case uncons arr of
-- |   Just { head: x, tail: xs } -> something
-- |   Nothing -> somethingElse
-- | ```
uncons :: forall a. Array a -> Maybe { head :: a, tail :: Array a }
uncons = uncons' (const Nothing) \x xs -> Just { head: x, tail: xs }

foreign import uncons'
  :: forall a b
   . (Unit -> b)
  -> (a -> Array a -> b)
  -> Array a
  -> b

-- | Break an array into its last element and all preceding elements.
-- |
-- | Running time: `O(n)` where `n` is the length of the array
unsnoc :: forall a. Array a -> Maybe { init :: Array a, last :: a }
unsnoc xs = { init: _, last: _ } <$> init xs <*> last xs

--------------------------------------------------------------------------------
-- Indexed operations ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | This function provides a safe way to read a value at a particular index
-- | from an array.
index :: forall a. Array a -> Int -> Maybe a
index = indexImpl Just Nothing

foreign import indexImpl
  :: forall a
   . (forall r. r -> Maybe r)
  -> (forall r. Maybe r)
  -> Array a
  -> Int
  -> Maybe a

-- | An infix version of `index`.
infixl 8 index as !!

-- | Find the index of the first element equal to the specified element.
elemIndex :: forall a. Eq a => a -> Array a -> Maybe Int
elemIndex x = findIndex (_ == x)

-- | Find the index of the last element equal to the specified element.
elemLastIndex :: forall a. Eq a => a -> Array a -> Maybe Int
elemLastIndex x = findLastIndex (_ == x)

-- | Find the first index for which a predicate holds.
findIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findIndex = findIndexImpl Just Nothing

foreign import findIndexImpl
  :: forall a
   . (forall b. b -> Maybe b)
  -> (forall b. Maybe b)
  -> (a -> Boolean)
  -> Array a
  -> Maybe Int

-- | Find the last index for which a predicate holds.
findLastIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findLastIndex = findLastIndexImpl Just Nothing

foreign import findLastIndexImpl
  :: forall a
   . (forall b. b -> Maybe b)
  -> (forall b. Maybe b)
  -> (a -> Boolean)
  -> Array a
  -> Maybe Int

-- | Insert an element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
insertAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
insertAt = _insertAt Just Nothing

foreign import _insertAt
  :: forall a
   . (forall b. b -> Maybe b)
  -> (forall b. Maybe b)
  -> Int
  -> a
  -> Array a
  -> Maybe (Array a)

-- | Delete the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
deleteAt :: forall a. Int -> Array a -> Maybe (Array a)
deleteAt = _deleteAt Just Nothing

foreign import _deleteAt
  :: forall a
   . (forall b. b -> Maybe b)
  -> (forall b. Maybe b)
  -> Int
  -> Array a
  -> Maybe (Array a)

-- | Change the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
updateAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
updateAt = _updateAt Just Nothing

foreign import _updateAt
  :: forall a
   . (forall b. b -> Maybe b)
  -> (forall b. Maybe b)
  -> Int
  -> a
  -> Array a
  -> Maybe (Array a)

-- | Apply a function to the element at the specified index, creating a new
-- | array, or returning `Nothing` if the index is out of bounds.
modifyAt :: forall a. Int -> (a -> a) -> Array a -> Maybe (Array a)
modifyAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = updateAt i (f x) xs

-- | Update or delete the element at the specified index by applying a
-- | function to the current value, returning a new array or `Nothing` if the
-- | index is out-of-bounds.
alterAt :: forall a. Int -> (a -> Maybe a) -> Array a -> Maybe (Array a)
alterAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = case f x of
    Nothing -> deleteAt i xs
    Just x' -> updateAt i x' xs

--------------------------------------------------------------------------------
-- Transformations -------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Reverse an array, creating a new array.
foreign import reverse :: forall a. Array a -> Array a

-- | Flatten an array of arrays, creating a new array.
foreign import concat :: forall a. Array (Array a) -> Array a

-- | Apply a function to each element in an array, and flatten the results
-- | into a single, new array.
concatMap :: forall a b. (a -> Array b) -> Array a -> Array b
concatMap = flip bind

-- | Filter an array, keeping the elements which satisfy a predicate function,
-- | creating a new array.
foreign import filter :: forall a. (a -> Boolean) -> Array a -> Array a

-- | Partition an array using a predicate function, creating a set of
-- | new arrays. One for the values satisfying the predicate function
-- | and one for values that don't.
foreign import partition
  :: forall a
   . (a -> Boolean)
  -> Array a
  -> { yes :: Array a, no :: Array a }

-- | Filter where the predicate returns a `Boolean` in some `Applicative`.
-- |
-- | ```purescript
-- | powerSet :: forall a. Array a -> Array (Array a)
-- | powerSet = filterA (const [true, false])
-- | ```
filterA :: forall a f. Applicative f => (a -> f Boolean) -> Array a -> f (Array a)
filterA p =
  traverse (\x -> Tuple x <$> p x)
  >>> map (mapMaybe (\(Tuple x b) -> if b then Just x else Nothing))

-- | Deprecated alias for `filterA`.
filterM :: forall a m. Monad m => (a -> m Boolean) -> Array a -> m (Array a)
filterM = filterA

-- | Apply a function to each element in an array, keeping only the results
-- | which contain a value, creating a new array.
mapMaybe :: forall a b. (a -> Maybe b) -> Array a -> Array b
mapMaybe f = concatMap (maybe [] singleton <<< f)

-- | Filter an array of optional values, keeping only the elements which contain
-- | a value, creating a new array.
catMaybes :: forall a. Array (Maybe a) -> Array a
catMaybes = mapMaybe id

-- | Apply a function to each element in an array, supplying a generated
-- | zero-based index integer along with the element, creating an array
-- | with the new elements.
mapWithIndex :: forall a b. (Int -> a -> b) -> Array a -> Array b
mapWithIndex f xs =
  zipWith f (range 0 (length xs - 1)) xs

--------------------------------------------------------------------------------
-- Sorting ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Sort the elements of an array in increasing order, creating a new array.
sort :: forall a. Ord a => Array a -> Array a
sort xs = sortBy compare xs

-- | Sort the elements of an array in increasing order, where elements are
-- | compared using the specified partial ordering, creating a new array.
sortBy :: forall a. (a -> a -> Ordering) -> Array a -> Array a
sortBy comp xs = sortImpl comp' xs
  where
  comp' x y = case comp x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortImpl :: forall a. (a -> a -> Int) -> Array a -> Array a

--------------------------------------------------------------------------------
-- Subarrays -------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Extract a subarray by a start and end index.
foreign import slice :: forall a. Int -> Int -> Array a -> Array a

-- | Keep only a number of elements from the start of an array, creating a new
-- | array.
foreign import take :: forall a. Int -> Array a -> Array a

-- | Calculate the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
takeWhile :: forall a. (a -> Boolean) -> Array a -> Array a
takeWhile p xs = (span p xs).init

-- | Drop a number of elements from the start of an array, creating a new array.
foreign import drop :: forall a. Int -> Array a -> Array a

-- | Remove the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
dropWhile :: forall a. (a -> Boolean) -> Array a -> Array a
dropWhile p xs = (span p xs).rest

-- | Split an array into two parts:
-- |
-- | 1. the longest initial subarray for which all elements satisfy the
-- |    specified predicate
-- | 2. the remaining elements
-- |
-- | ```purescript
-- | span (\n -> n % 2 == 1) [1,3,2,4,5] == { init: [1,3], rest: [2,4,5] }
-- | ```
-- |
-- | Running time: `O(n)`.
span
  :: forall a
   . (a -> Boolean)
  -> Array a
  -> { init :: Array a, rest :: Array a }
span p arr =
  case breakIndex of
    Just 0 ->
      { init: [], rest: arr }
    Just i ->
      { init: slice 0 i arr, rest: slice i (length arr) arr }
    Nothing ->
      { init: arr, rest: [] }
  where
  breakIndex = go 0
  go i =
    -- This looks like a good opportunity to use the Monad Maybe instance,
    -- but it's important to write out an explicit case expression here in
    -- order to ensure that TCO is triggered.
    case index arr i of
      Just x -> if p x then go (i+1) else Just i
      Nothing -> Nothing

-- | Group equal, consecutive elements of an array into arrays.
-- |
-- | ```purescript
-- | group [1,1,2,2,1] == [[1,1],[2,2],[1]]
-- | ```
group :: forall a. Eq a => Array a -> Array (NonEmpty Array a)
group xs = groupBy eq xs

-- | Sort and then group the elements of an array into arrays.
-- |
-- | ```purescript
-- | group' [1,1,2,2,1] == [[1,1,1],[2,2]]
-- | ```
group' :: forall a. Ord a => Array a -> Array (NonEmpty Array a)
group' = group <<< sort

-- | Group equal, consecutive elements of an array into arrays, using the
-- | specified equivalence relation to detemine equality.
groupBy :: forall a. (a -> a -> Boolean) -> Array a -> Array (NonEmpty Array a)
groupBy op xs =
  pureST do
    result <- emptySTArray
    iter <- iterator (xs !! _)
    iterate iter \x -> void do
      sub <- emptySTArray
      pushWhile (op x) iter sub
      sub_ <- unsafeFreeze sub
      pushSTArray result (x :| sub_)
    unsafeFreeze result

-- | Remove the duplicates from an array, creating a new array.
nub :: forall a. Eq a => Array a -> Array a
nub = nubBy eq

-- | Remove the duplicates from an array, where element equality is determined
-- | by the specified equivalence relation, creating a new array.
nubBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a
nubBy eq xs =
  case uncons xs of
    Just o -> o.head : nubBy eq (filter (\y -> not (o.head `eq` y)) o.tail)
    Nothing -> []

-- | Calculate the union of two arrays. Note that duplicates in the first array
-- | are preserved while duplicates in the second array are removed.
-- |
-- | Running time: `O(n^2)`
union :: forall a. Eq a => Array a -> Array a -> Array a
union = unionBy (==)

-- | Calculate the union of two arrays, using the specified function to
-- | determine equality of elements. Note that duplicates in the first array
-- | are preserved while duplicates in the second array are removed.
unionBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
unionBy eq xs ys = xs <> foldl (flip (deleteBy eq)) (nubBy eq ys) xs

-- | Delete the first element of an array which is equal to the specified value,
-- | creating a new array.
-- |
-- | Running time: `O(n)`
delete :: forall a. Eq a => a -> Array a -> Array a
delete = deleteBy eq

-- | Delete the first element of an array which matches the specified value,
-- | under the equivalence relation provided in the first argument, creating a
-- | new array.
deleteBy :: forall a. (a -> a -> Boolean) -> a -> Array a -> Array a
deleteBy _  _ [] = []
deleteBy eq x ys = maybe ys (\i -> unsafePartial $ fromJust (deleteAt i ys)) (findIndex (eq x) ys)

-- | Delete the first occurrence of each element in the second array from the
-- | first array, creating a new array.
-- |
-- | Running time: `O(n*m)`, where n is the length of the first array, and m is
-- | the length of the second.
difference :: forall a. Eq a => Array a -> Array a -> Array a
difference = foldr delete

infix 5 difference as \\

-- | Calculate the intersection of two arrays, creating a new array. Note that
-- | duplicates in the first array are preserved while duplicates in the second
-- | array are removed.
intersect :: forall a. Eq a => Array a -> Array a -> Array a
intersect = intersectBy eq

-- | Calculate the intersection of two arrays, using the specified equivalence
-- | relation to compare elements, creating a new array. Note that duplicates
-- | in the first array are preserved while duplicates in the second array are
-- | removed.
intersectBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
intersectBy eq xs ys = filter (\x -> isJust (findIndex (eq x) ys)) xs

-- | Apply a function to pairs of elements at the same index in two arrays,
-- | collecting the results in a new array.
-- |
-- | If one array is longer, elements will be discarded from the longer array.
-- |
-- | For example
-- |
-- | ```purescript
-- | zipWith (*) [1, 2, 3] [4, 5, 6, 7] == [4, 10, 18]
-- | ```
foreign import zipWith
  :: forall a b c
   . (a -> b -> c)
  -> Array a
  -> Array b
  -> Array c

-- | A generalization of `zipWith` which accumulates results in some
-- | `Applicative` functor.
zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> Array a
  -> Array b
  -> m (Array c)
zipWithA f xs ys = sequence (zipWith f xs ys)

-- | Rakes two lists and returns a list of corresponding pairs.
-- | If one input list is short, excess elements of the longer list are
-- | discarded.
zip :: forall a b. Array a -> Array b -> Array (Tuple a b)
zip = zipWith Tuple

-- | Transforms a list of pairs into a list of first components and a list of
-- | second components.
unzip :: forall a b. Array (Tuple a b) -> Tuple (Array a) (Array b)
unzip = uncons' (\_ -> Tuple [] []) \(Tuple a b) ts -> case unzip ts of
  Tuple as bs -> Tuple (a : as) (b : bs)

-- | Perform a fold using a monadic step function.
foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> Array b -> m a
foldM f a = uncons' (\_ -> pure a) (\b bs -> f a b >>= \a' -> foldM f a' bs)

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> Array b -> m a
foldRecM f a array = tailRecM2 go a 0
  where
  go res i
    | i >= length array = pure (Done res)
    | otherwise = do
        res' <- f res (unsafePartial (unsafeIndex array i))
        pure (Loop { a: res', b: i + 1 })

-- | Find the element of an array at the specified index.
unsafeIndex :: forall a. Partial => Array a -> Int -> a
unsafeIndex = unsafeIndexImpl

foreign import unsafeIndexImpl :: forall a. Array a -> Int -> a

-- | Helper functions for working with immutable Javascript arrays.
-- |
-- | _Note_: Depending on your use-case, you may prefer to use `Data.List` or
-- | `Data.Sequence` instead, which might give better performance for certain
-- | use cases. This module is useful when integrating with JavaScript libraries
-- | which use arrays, but immutable arrays are not a practical data structure
-- | for many use cases due to their poor asymptotics.
-- |
-- | In addition to the functions in this module, Arrays have a number of
-- | useful instances:
-- |
-- | * `Functor`, which provides `map :: forall a b. (a -> b) -> Array a ->
-- |   Array b`
-- | * `Apply`, which provides `(<*>) :: forall a b. Array (a -> b) -> Array a
-- |   -> Array b`. This function works a bit like a Cartesian product; the
-- |   result array is constructed by applying each function in the first
-- |   array to each value in the second, so that the result array ends up with
-- |   a length equal to the product of the two arguments' lengths.
-- | * `Bind`, which provides `(>>=) :: forall a b. (a -> Array b) -> Array a
-- |   -> Array b` (this is the same as `concatMap`).
-- | * `Semigroup`, which provides `(<>) :: forall a. Array a -> Array a ->
-- |   Array a`, for concatenating arrays.
-- | * `Foldable`, which provides a slew of functions for *folding* (also known
-- |   as *reducing*) arrays down to one value. For example,
-- |   `Data.Foldable.or` tests whether an array of `Boolean` values contains
-- |   at least one `true` value.
-- | * `Traversable`, which provides the PureScript version of a for-loop,
-- |   allowing you to iterate over an array and accumulate effects.
-- |
module Data.Array
  ( fromFoldable
  , toUnfoldable
  , singleton
  , (..), range
  , replicate
  , some
  , many

  , null
  , length

  , (:), cons
  , snoc
  , insert
  , insertBy

  , head
  , last
  , tail
  , init
  , uncons
  , unsnoc

  , (!!), index
  , elemIndex
  , elemLastIndex
  , findIndex
  , findLastIndex
  , insertAt
  , deleteAt
  , updateAt
  , modifyAt
  , alterAt

  , reverse
  , concat
  , concatMap
  , filter
  , partition
  , filterA
  , filterM
  , mapMaybe
  , catMaybes
  , mapWithIndex

  , sort
  , sortBy

  , slice
  , take
  , takeWhile
  , drop
  , dropWhile
  , span
  , group
  , group'
  , groupBy

  , nub
  , nubBy
  , union
  , unionBy
  , delete
  , deleteBy

  , (\\), difference
  , intersect
  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex

  , module Exports
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy, defer)
import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM2)

import Data.Foldable (class Foldable, foldl, foldr)
import Data.Foldable (foldl, foldr, foldMap, fold, intercalate, elem, notElem, find, findMap, any, all) as Exports
import Data.Maybe (Maybe(..), maybe, isJust, fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Traversable (scanl, scanr) as Exports
import Data.Traversable (sequence, traverse)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable, unfoldr)

import Partial.Unsafe (unsafePartial)

-- | Convert an `Array` into an `Unfoldable` structure.
toUnfoldable :: forall f a. Unfoldable f => Array a -> f a
toUnfoldable xs = unfoldr f 0
  where
  len = length xs
  f i
    | i < len   = Just (Tuple (unsafePartial (unsafeIndex xs i)) (i+1))
    | otherwise = Nothing

-- | Convert a `Foldable` structure into an `Array`.
fromFoldable :: forall f a. Foldable f => f a -> Array a
fromFoldable = fromFoldableImpl foldr

foreign import fromFoldableImpl
  :: forall f a
   . (forall b. (a -> b -> b) -> b -> f a -> b)
  -> f a
  -> Array a

-- | Create an array of one element
singleton :: forall a. a -> Array a
singleton a = [a]

-- | Create an array containing a range of integers, including both endpoints.
foreign import range :: Int -> Int -> Array Int

-- | Create an array containing a value repeated the specified number of times.
foreign import replicate :: forall a. Int -> a -> Array a

-- | An infix synonym for `range`.
infix 8 range as ..

-- | Attempt a computation multiple times, requiring at least one success.
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
some :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
some v = (:) <$> v <*> defer (\_ -> many v)

-- | Attempt a computation multiple times, returning as many successful results
-- | as possible (possibly zero).
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
many :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
many v = some v <|> pure []

--------------------------------------------------------------------------------
-- Array size ------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test whether an array is empty.
null :: forall a. Array a -> Boolean
null xs = length xs == 0

-- | Get the number of elements in an array.
foreign import length :: forall a. Array a -> Int

--------------------------------------------------------------------------------
-- Extending arrays ------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Attaches an element to the front of an array, creating a new array.
-- |
-- | ```purescript
-- | cons 1 [2, 3, 4] = [1, 2, 3, 4]
-- | ```
-- |
-- | Note, the running time of this function is `O(n)`.
foreign import cons :: forall a. a -> Array a -> Array a

-- | An infix alias for `cons`.
-- |
-- | Note, the running time of this function is `O(n)`.
infixr 6 cons as :

-- | Append an element to the end of an array, creating a new array.
foreign import snoc :: forall a. Array a -> a -> Array a

-- | Insert an element into a sorted array.
insert :: forall a. Ord a => a -> Array a -> Array a
insert = insertBy compare

-- | Insert an element into a sorted array, using the specified function to
-- | determine the ordering of elements.
insertBy :: forall a. (a -> a -> Ordering) -> a -> Array a -> Array a
insertBy cmp x ys =
  let i = maybe 0 (_ + 1) (findLastIndex (\y -> cmp x y == GT) ys)
  in unsafePartial (fromJust (insertAt i x ys))

--------------------------------------------------------------------------------
-- Non-indexed reads -----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Get the first element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
head :: forall a. Array a -> Maybe a
head xs = xs !! 0

-- | Get the last element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
last :: forall a. Array a -> Maybe a
last xs = xs !! (length xs - 1)

-- | Get all but the first element of an array, creating a new array, or
-- | `Nothing` if the array is empty
-- |
-- | Running time: `O(n)` where `n` is the length of the array
tail :: forall a. Array a -> Maybe (Array a)
tail = uncons' (const Nothing) (\_ xs -> Just xs)

-- | Get all but the last element of an array, creating a new array, or
-- | `Nothing` if the array is empty.
-- |
-- | Running time: `O(n)` where `n` is the length of the array
init :: forall a. Array a -> Maybe (Array a)
init xs
  | null xs = Nothing
  | otherwise = Just (slice zero (length xs - one) xs)

-- | Break an array into its first element and remaining elements.
-- |
-- | Using `uncons` provides a way of writing code that would use cons patterns
-- | in Haskell or pre-PureScript 0.7:
-- | ``` purescript
-- | f (x : xs) = something
-- | f [] = somethingElse
-- | ```
-- | Becomes:
-- | ``` purescript
-- | f arr = case uncons arr of
-- |   Just { head: x, tail: xs } -> something
-- |   Nothing -> somethingElse
-- | ```
uncons :: forall a. Array a -> Maybe { head :: a, tail :: Array a }
uncons = uncons' (const Nothing) \x xs -> Just { head: x, tail: xs }

foreign import uncons'
  :: forall a b
   . (Unit -> b)
  -> (a -> Array a -> b)
  -> Array a
  -> b

-- | Break an array into its last element and all preceding elements.
-- |
-- | Running time: `O(n)` where `n` is the length of the array
unsnoc :: forall a. Array a -> Maybe { init :: Array a, last :: a }
unsnoc xs = { init: _, last: _ } <$> init xs <*> last xs

--------------------------------------------------------------------------------
-- Indexed operations ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | This function provides a safe way to read a value at a particular index
-- | from an array.
index :: forall a. Array a -> Int -> Maybe a
index = indexImpl Just Nothing

foreign import indexImpl
  :: forall a
   . (forall r. r -> Maybe r)
  -> (forall r. Maybe r)
  -> Array a
  -> Int
  -> Maybe a

-- | An infix version of `index`.
infixl 8 index as !!

-- | Find the index of the first element equal to the specified element.
elemIndex :: forall a. Eq a => a -> Array a -> Maybe Int
elemIndex x = findIndex (_ == x)

-- | Find the index of the last element equal to the specified element.
elemLastIndex :: forall a. Eq a => a -> Array a -> Maybe Int
elemLastIndex x = findLastIndex (_ == x)

-- | Find the first index for which a predicate holds.
findIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findIndex = findIndexImpl Just Nothing

foreign import findIndexImpl
  :: forall a
   . (forall b. b -> Maybe b)
  -> (forall b. Maybe b)
  -> (a -> Boolean)
  -> Array a
  -> Maybe Int

-- | Find the last index for which a predicate holds.
findLastIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findLastIndex = findLastIndexImpl Just Nothing

foreign import findLastIndexImpl
  :: forall a
   . (forall b. b -> Maybe b)
  -> (forall b. Maybe b)
  -> (a -> Boolean)
  -> Array a
  -> Maybe Int

-- | Insert an element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
insertAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
insertAt = _insertAt Just Nothing

foreign import _insertAt
  :: forall a
   . (forall b. b -> Maybe b)
  -> (forall b. Maybe b)
  -> Int
  -> a
  -> Array a
  -> Maybe (Array a)

-- | Delete the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
deleteAt :: forall a. Int -> Array a -> Maybe (Array a)
deleteAt = _deleteAt Just Nothing

foreign import _deleteAt
  :: forall a
   . (forall b. b -> Maybe b)
  -> (forall b. Maybe b)
  -> Int
  -> Array a
  -> Maybe (Array a)

-- | Change the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
updateAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
updateAt = _updateAt Just Nothing

foreign import _updateAt
  :: forall a
   . (forall b. b -> Maybe b)
  -> (forall b. Maybe b)
  -> Int
  -> a
  -> Array a
  -> Maybe (Array a)

-- | Apply a function to the element at the specified index, creating a new
-- | array, or returning `Nothing` if the index is out of bounds.
modifyAt :: forall a. Int -> (a -> a) -> Array a -> Maybe (Array a)
modifyAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = updateAt i (f x) xs

-- | Update or delete the element at the specified index by applying a
-- | function to the current value, returning a new array or `Nothing` if the
-- | index is out-of-bounds.
alterAt :: forall a. Int -> (a -> Maybe a) -> Array a -> Maybe (Array a)
alterAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = case f x of
    Nothing -> deleteAt i xs
    Just x' -> updateAt i x' xs

--------------------------------------------------------------------------------
-- Transformations -------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Reverse an array, creating a new array.
foreign import reverse :: forall a. Array a -> Array a

-- | Flatten an array of arrays, creating a new array.
foreign import concat :: forall a. Array (Array a) -> Array a

-- | Apply a function to each element in an array, and flatten the results
-- | into a single, new array.
concatMap :: forall a b. (a -> Array b) -> Array a -> Array b
concatMap = flip bind

-- | Filter an array, keeping the elements which satisfy a predicate function,
-- | creating a new array.
foreign import filter :: forall a. (a -> Boolean) -> Array a -> Array a

-- | Partition an array using a predicate function, creating a set of
-- | new arrays. One for the values satisfying the predicate function
-- | and one for values that don't.
foreign import partition
  :: forall a
   . (a -> Boolean)
  -> Array a
  -> { yes :: Array a, no :: Array a }

-- | Filter where the predicate returns a `Boolean` in some `Applicative`.
-- |
-- | ```purescript
-- | powerSet :: forall a. Array a -> Array (Array a)
-- | powerSet = filterA (const [true, false])
-- | ```
filterA :: forall a f. Applicative f => (a -> f Boolean) -> Array a -> f (Array a)
filterA p =
  traverse (\x -> Tuple x <$> p x)
  >>> map (mapMaybe (\(Tuple x b) -> if b then Just x else Nothing))

-- | Deprecated alias for `filterA`.
filterM :: forall a m. Monad m => (a -> m Boolean) -> Array a -> m (Array a)
filterM = filterA

-- | Apply a function to each element in an array, keeping only the results
-- | which contain a value, creating a new array.
mapMaybe :: forall a b. (a -> Maybe b) -> Array a -> Array b
mapMaybe f = concatMap (maybe [] singleton <<< f)

-- | Filter an array of optional values, keeping only the elements which contain
-- | a value, creating a new array.
catMaybes :: forall a. Array (Maybe a) -> Array a
catMaybes = mapMaybe id

-- | Apply a function to each element in an array, supplying a generated
-- | zero-based index integer along with the element, creating an array
-- | with the new elements.
mapWithIndex :: forall a b. (Int -> a -> b) -> Array a -> Array b
mapWithIndex f xs =
  zipWith f (range 0 (length xs - 1)) xs

--------------------------------------------------------------------------------
-- Sorting ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Sort the elements of an array in increasing order, creating a new array.
sort :: forall a. Ord a => Array a -> Array a
sort xs = sortBy compare xs

-- | Sort the elements of an array in increasing order, where elements are
-- | compared using the specified partial ordering, creating a new array.
sortBy :: forall a. (a -> a -> Ordering) -> Array a -> Array a
sortBy comp xs = sortImpl comp' xs
  where
  comp' x y = case comp x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortImpl :: forall a. (a -> a -> Int) -> Array a -> Array a

--------------------------------------------------------------------------------
-- Subarrays -------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Extract a subarray by a start and end index.
foreign import slice :: forall a. Int -> Int -> Array a -> Array a

-- | Keep only a number of elements from the start of an array, creating a new
-- | array.
foreign import take :: forall a. Int -> Array a -> Array a

-- | Calculate the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
takeWhile :: forall a. (a -> Boolean) -> Array a -> Array a
takeWhile p xs = (span p xs).init

-- | Drop a number of elements from the start of an array, creating a new array.
foreign import drop :: forall a. Int -> Array a -> Array a

-- | Remove the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
dropWhile :: forall a. (a -> Boolean) -> Array a -> Array a
dropWhile p xs = (span p xs).rest

-- | Split an array into two parts:
-- |
-- | 1. the longest initial subarray for which all elements satisfy the
-- |    specified predicate
-- | 2. the remaining elements
-- |
-- | ```purescript
-- | span (\n -> n % 2 == 1) [1,3,2,4,5] == { init: [1,3], rest: [2,4,5] }
-- | ```
-- |
-- | Running time: `O(n)`.
span
  :: forall a
   . (a -> Boolean)
  -> Array a
  -> { init :: Array a, rest :: Array a }
span p arr =
  case breakIndex of
    Just 0 ->
      { init: [], rest: arr }
    Just i ->
      { init: slice 0 i arr, rest: slice i (length arr) arr }
    Nothing ->
      { init: arr, rest: [] }
  where
  breakIndex = go 0
  go i =
    -- This looks like a good opportunity to use the Monad Maybe instance,
    -- but it's important to write out an explicit case expression here in
    -- order to ensure that TCO is triggered.
    case index arr i of
      Just x -> if p x then go (i+1) else Just i
      Nothing -> Nothing

-- | Group equal, consecutive elements of an array into arrays.
-- |
-- | ```purescript
-- | group [1,1,2,2,1] == [[1,1],[2,2],[1]]
-- | ```
group :: forall a. Eq a => Array a -> Array (NonEmpty Array a)
group xs = groupBy eq xs

-- | Sort and then group the elements of an array into arrays.
-- |
-- | ```purescript
-- | group' [1,1,2,2,1] == [[1,1,1],[2,2]]
-- | ```
group' :: forall a. Ord a => Array a -> Array (NonEmpty Array a)
group' = group <<< sort

-- | Group equal, consecutive elements of an array into arrays, using the
-- | specified equivalence relation to detemine equality.
groupBy :: forall a. (a -> a -> Boolean) -> Array a -> Array (NonEmpty Array a)
groupBy op = go []
  where
  go :: Array (NonEmpty Array a) -> Array a -> Array (NonEmpty Array a)
  go acc xs = case uncons xs of
    Just o ->
      let sp = span (op o.head) o.tail
      in go ((o.head :| sp.init) : acc) sp.rest
    Nothing -> reverse acc

-- | Remove the duplicates from an array, creating a new array.
nub :: forall a. Eq a => Array a -> Array a
nub = nubBy eq

-- | Remove the duplicates from an array, where element equality is determined
-- | by the specified equivalence relation, creating a new array.
nubBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a
nubBy eq xs =
  case uncons xs of
    Just o -> o.head : nubBy eq (filter (\y -> not (o.head `eq` y)) o.tail)
    Nothing -> []

-- | Calculate the union of two arrays. Note that duplicates in the first array
-- | are preserved while duplicates in the second array are removed.
-- |
-- | Running time: `O(n^2)`
union :: forall a. Eq a => Array a -> Array a -> Array a
union = unionBy (==)

-- | Calculate the union of two arrays, using the specified function to
-- | determine equality of elements. Note that duplicates in the first array
-- | are preserved while duplicates in the second array are removed.
unionBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
unionBy eq xs ys = xs <> foldl (flip (deleteBy eq)) (nubBy eq ys) xs

-- | Delete the first element of an array which is equal to the specified value,
-- | creating a new array.
-- |
-- | Running time: `O(n)`
delete :: forall a. Eq a => a -> Array a -> Array a
delete = deleteBy eq

-- | Delete the first element of an array which matches the specified value,
-- | under the equivalence relation provided in the first argument, creating a
-- | new array.
deleteBy :: forall a. (a -> a -> Boolean) -> a -> Array a -> Array a
deleteBy _  _ [] = []
deleteBy eq x ys = maybe ys (\i -> unsafePartial $ fromJust (deleteAt i ys)) (findIndex (eq x) ys)

-- | Delete the first occurrence of each element in the second array from the
-- | first array, creating a new array.
-- |
-- | Running time: `O(n*m)`, where n is the length of the first array, and m is
-- | the length of the second.
difference :: forall a. Eq a => Array a -> Array a -> Array a
difference = foldr delete

infix 5 difference as \\

-- | Calculate the intersection of two arrays, creating a new array. Note that
-- | duplicates in the first array are preserved while duplicates in the second
-- | array are removed.
intersect :: forall a. Eq a => Array a -> Array a -> Array a
intersect = intersectBy eq

-- | Calculate the intersection of two arrays, using the specified equivalence
-- | relation to compare elements, creating a new array. Note that duplicates
-- | in the first array are preserved while duplicates in the second array are
-- | removed.
intersectBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
intersectBy eq xs ys = filter (\x -> isJust (findIndex (eq x) ys)) xs

-- | Apply a function to pairs of elements at the same index in two arrays,
-- | collecting the results in a new array.
-- |
-- | If one array is longer, elements will be discarded from the longer array.
-- |
-- | For example
-- |
-- | ```purescript
-- | zipWith (*) [1, 2, 3] [4, 5, 6, 7] == [4, 10, 18]
-- | ```
foreign import zipWith
  :: forall a b c
   . (a -> b -> c)
  -> Array a
  -> Array b
  -> Array c

-- | A generalization of `zipWith` which accumulates results in some
-- | `Applicative` functor.
zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> Array a
  -> Array b
  -> m (Array c)
zipWithA f xs ys = sequence (zipWith f xs ys)

-- | Rakes two lists and returns a list of corresponding pairs.
-- | If one input list is short, excess elements of the longer list are
-- | discarded.
zip :: forall a b. Array a -> Array b -> Array (Tuple a b)
zip = zipWith Tuple

-- | Transforms a list of pairs into a list of first components and a list of
-- | second components.
unzip :: forall a b. Array (Tuple a b) -> Tuple (Array a) (Array b)
unzip = uncons' (\_ -> Tuple [] []) \(Tuple a b) ts -> case unzip ts of
  Tuple as bs -> Tuple (a : as) (b : bs)

-- | Perform a fold using a monadic step function.
foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> Array b -> m a
foldM f a = uncons' (\_ -> pure a) (\b bs -> f a b >>= \a' -> foldM f a' bs)

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> Array b -> m a
foldRecM f a array = tailRecM2 go a 0
  where
  go res i
    | i >= length array = pure (Done res)
    | otherwise = do
        res' <- f res (unsafePartial (unsafeIndex array i))
        pure (Loop { a: res', b: i + 1 })

-- | Find the element of an array at the specified index.
unsafeIndex :: forall a. Partial => Array a -> Int -> a
unsafeIndex = unsafeIndexImpl

foreign import unsafeIndexImpl :: forall a. Array a -> Int -> a


Initial value of `touch` should be the empty list.

module Signal.DOM
  ( animationFrame
  , keyPressed
  , mouseButton
  , touch
  , tap
  , mousePos
  , CoordinatePair(..)
  , Touch(..)
  ) where

import Control.Monad.Eff (Eff(..))
import Control.Timer (Timer(..))
import Data.Function
import DOM (DOM(..))
import Signal (constant, Signal(..), (~>), unwrap)
import Signal.Time (now, Time(..))

type CoordinatePair = { x :: Number, y :: Number }

foreign import keyPressedP """
  function keyPressedP(constant, keyCode) {
    return function() {
      var out = constant(false);
      window.addEventListener("keydown", function(e) {
        if (e.keyCode === keyCode) out.set(true);
      });
      window.addEventListener("keyup", function(e) {
        if (e.keyCode === keyCode) out.set(false);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

keyPressed :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
keyPressed = runFn2 keyPressedP constant

foreign import mouseButtonP """
  function mouseButtonP(constant, button) {
    return function() {
      var out = constant(false);
      window.addEventListener("mousedown", function(e) {
        if (e.button === button) out.set(true);
      });
      window.addEventListener("mouseup", function(e) {
        if (e.button === button) out.set(false);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

mouseButton :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
mouseButton = runFn2 mouseButtonP constant

type Touch = { id :: String
             , screenX :: Number, screenY :: Number
             , clientX :: Number, clientY :: Number
             , pageX :: Number, pageY :: Number
             , radiusX :: Number, radiusY :: Number
             , rotationAngle :: Number, force :: Number }

foreign import touchP """
  function touchP(constant) {
    var out = constant([]);
    function report(e) {
      var touches = [], i, l = e.touches.length;
      for (i = 0; i < l; i++) touches.push(e.touches.item(i));
      out.set(touches);
    }
    window.addEventListener("touchstart", report);
    window.addEventListener("touchend", report);
    window.addEventListener("touchmove", report);
    window.addEventListener("touchcancel", report);
    return function() {
      return out;
    };
  }""" :: forall e c. Fn1 (c -> Signal c) (Eff (dom :: DOM | e) (Signal [Touch]))

touch :: forall e. Eff (dom :: DOM | e) (Signal [Touch])
touch = runFn1 touchP constant

tap :: forall e. Eff (dom :: DOM | e) (Signal Boolean)
tap = do
  touches <- touch
  return $ touches ~> \t -> case t of
    [] -> false
    _ -> true

foreign import mousePosP """
  function mousePosP(constant) {
    var out = constant({x:0,y:0});
    window.addEventListener('mousemove', function(e) {
      if (e.pageX !== undefined && e.pageY !== undefined) {
        out.set({x:e.pageX, y: e.pageY});
      } else if (e.clientX !== undefined && e.clientY !== undefined) {
        out.set({
          x: e.clientX + document.body.scrollLeft +
             document.documentElement.scrollLeft,
          y: e.clientY + document.body.scrollTop +
             document.documentElement.scrollTop
        });
      } else {
        throw new Error('Mouse event has no coordinates I recognise!');
      }
    });
    return function() {
      return out;
    };
  }""" :: forall e c. (c -> Signal c) -> Eff (dom :: DOM | e) (Signal CoordinatePair)

mousePos :: forall e. Eff (dom :: DOM | e) (Signal CoordinatePair)
mousePos = mousePosP constant

foreign import animationFrameP """
  function animationFrameP(constant, now) {
    return function() {
      var requestAnimFrame, cancelAnimFrame;
      if (window.requestAnimationFrame) {
        requestAnimFrame = window.requestAnimationFrame;
        cancelAnimFrame = window.cancelAnimationFrame;
      } else if (window.mozRequestAnimationFrame) {
        requestAnimFrame = window.mozRequestAnimationFrame;
        cancelAnimFrame = window.mozCancelAnimationFrame;
      } else if (window.webkitRequestAnimationFrame) {
        requestAnimFrame = window.webkitRequestAnimationFrame;
        cancelAnimFrame = window.webkitCancelAnimationFrame;
      } else if (window.msRequestAnimationFrame) {
        requestAnimFrame = window.msRequestAnimationFrame;
        cancelAnimFrame = window.msCancelAnimationFrame;
      } else if (window.oRequestAnimationFrame) {
        requestAnimFrame = window.oRequestAnimationFrame;
        cancelAnimFrame = window.oCancelAnimationFrame;
      } else {
        requestAnimFrame = function(cb) {setTimeout(function() {cb(now())}, 1000/60)};
        cancelAnimFrame = window.clearTimeout;
      }
      var out = constant(now());
      requestAnimFrame(function tick(t) {
        out.set(t); requestAnimFrame(tick);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) (Eff (timer :: Timer | e) Time) (Eff (dom :: DOM, timer :: Timer | e) (Signal Time))

animationFrame :: forall e. Eff (dom :: DOM, timer :: Timer | e) (Signal Time)
animationFrame = runFn2 animationFrameP constant now

module Signal.DOM
  ( animationFrame
  , keyPressed
  , mouseButton
  , touch
  , tap
  , mousePos
  , CoordinatePair(..)
  , Touch(..)
  ) where

import Control.Monad.Eff (Eff(..))
import Control.Timer (Timer(..))
import Data.Function
import DOM (DOM(..))
import Signal (constant, Signal(..), (~>), unwrap)
import Signal.Time (now, Time(..))

type CoordinatePair = { x :: Number, y :: Number }

foreign import keyPressedP """
  function keyPressedP(constant, keyCode) {
    return function() {
      var out = constant(false);
      window.addEventListener("keydown", function(e) {
        if (e.keyCode === keyCode) out.set(true);
      });
      window.addEventListener("keyup", function(e) {
        if (e.keyCode === keyCode) out.set(false);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

keyPressed :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
keyPressed = runFn2 keyPressedP constant

foreign import mouseButtonP """
  function mouseButtonP(constant, button) {
    return function() {
      var out = constant(false);
      window.addEventListener("mousedown", function(e) {
        if (e.button === button) out.set(true);
      });
      window.addEventListener("mouseup", function(e) {
        if (e.button === button) out.set(false);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

mouseButton :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
mouseButton = runFn2 mouseButtonP constant

type Touch = { id :: String
             , screenX :: Number, screenY :: Number
             , clientX :: Number, clientY :: Number
             , pageX :: Number, pageY :: Number
             , radiusX :: Number, radiusY :: Number
             , rotationAngle :: Number, force :: Number }

foreign import touchP """
  function touchP(constant) {
    var out = constant(false);
    function report(e) {
      var touches = [], i, l = e.touches.length;
      for (i = 0; i < l; i++) touches.push(e.touches.item(i));
      out.set(touches);
    }
    window.addEventListener("touchstart", report);
    window.addEventListener("touchend", report);
    window.addEventListener("touchmove", report);
    window.addEventListener("touchcancel", report);
    return function() {
      return out;
    };
  }""" :: forall e c. Fn1 (c -> Signal c) (Eff (dom :: DOM | e) (Signal [Touch]))

touch :: forall e. Eff (dom :: DOM | e) (Signal [Touch])
touch = runFn1 touchP constant

tap :: forall e. Eff (dom :: DOM | e) (Signal Boolean)
tap = do
  touches <- touch
  return $ touches ~> \t -> case t of
    [] -> false
    _ -> true

foreign import mousePosP """
  function mousePosP(constant) {
    var out = constant({x:0,y:0});
    window.addEventListener('mousemove', function(e) {
      if (e.pageX !== undefined && e.pageY !== undefined) {
        out.set({x:e.pageX, y: e.pageY});
      } else if (e.clientX !== undefined && e.clientY !== undefined) {
        out.set({
          x: e.clientX + document.body.scrollLeft +
             document.documentElement.scrollLeft,
          y: e.clientY + document.body.scrollTop +
             document.documentElement.scrollTop
        });
      } else {
        throw new Error('Mouse event has no coordinates I recognise!');
      }
    });
    return function() {
      return out;
    };
  }""" :: forall e c. (c -> Signal c) -> Eff (dom :: DOM | e) (Signal CoordinatePair)

mousePos :: forall e. Eff (dom :: DOM | e) (Signal CoordinatePair)
mousePos = mousePosP constant

foreign import animationFrameP """
  function animationFrameP(constant, now) {
    return function() {
      var requestAnimFrame, cancelAnimFrame;
      if (window.requestAnimationFrame) {
        requestAnimFrame = window.requestAnimationFrame;
        cancelAnimFrame = window.cancelAnimationFrame;
      } else if (window.mozRequestAnimationFrame) {
        requestAnimFrame = window.mozRequestAnimationFrame;
        cancelAnimFrame = window.mozCancelAnimationFrame;
      } else if (window.webkitRequestAnimationFrame) {
        requestAnimFrame = window.webkitRequestAnimationFrame;
        cancelAnimFrame = window.webkitCancelAnimationFrame;
      } else if (window.msRequestAnimationFrame) {
        requestAnimFrame = window.msRequestAnimationFrame;
        cancelAnimFrame = window.msCancelAnimationFrame;
      } else if (window.oRequestAnimationFrame) {
        requestAnimFrame = window.oRequestAnimationFrame;
        cancelAnimFrame = window.oCancelAnimationFrame;
      } else {
        requestAnimFrame = function(cb) {setTimeout(function() {cb(now())}, 1000/60)};
        cancelAnimFrame = window.clearTimeout;
      }
      var out = constant(now());
      requestAnimFrame(function tick(t) {
        out.set(t); requestAnimFrame(tick);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) (Eff (timer :: Timer | e) Time) (Eff (dom :: DOM, timer :: Timer | e) (Signal Time))

animationFrame :: forall e. Eff (dom :: DOM, timer :: Timer | e) (Signal Time)
animationFrame = runFn2 animationFrameP constant now


Added the basic operators map

Added the basic operators map

module OpCodeMap where

import Prelude

import Types
import Ops

--Tried to use typeclasses, but was forced to turn all my type synonyms
--to 'newtypes' which will require writing a specialised function for each
--case to convert from the type synonyms to the newtypes which will beat
--the purpose of using a typeclass in the first place (lets me have function
--overload in this case).
rr2op :: (Regs -> Regs) -> Z80State -> Z80State
rr2op rr state@{mem=mem@{regs}} = state { mem = mem { regs = rr regs } }

mr2op :: (Mem -> Regs) -> Z80State -> Z80State
mr2op mr state@{mem=mem@{regs}} = state { mem = mem { regs = mr mem } }

mm2op :: (Mem -> Mem) -> Z80State -> Z80State
mm2op mm state@{mem=mem@{regs}} = state { mem = mm mem }

basicOps :: Array (Z80State -> Z80State)
basicOps =
                                            -- 0x
  [ rr2op $ nop                             -- NOP
  , mr2op $ ldTwoRegsFromImm setB setC      -- LD BC,nn
  , mm2op $ ldMem2RFromReg b c a            -- LD (BC),A
  , rr2op $ incRegWithCarry b c setB setC   -- INC BC

  , rr2op $ incReg b setB                   -- INC B
  , rr2op $ decReg b setB                   -- DEC B
  , mr2op $ ldRegFromImm setB               -- LD B,n
  , rr2op $ rotA Left true                  -- RLC A

  , mm2op $ ldMemImmFromSP                  -- LD (nn),SP
  , rr2op $ add2RegsToHL b c                -- ADD HL,BC
  , mr2op $ ldRegFromMem2R setA b c         -- LD A,(BC)
  , rr2op $ decRegWithCarry b c setB setC   -- DEC BC

  , rr2op $ incReg c setC                   -- INC C
  , rr2op $ decReg c setC                   -- DEC C
  , mr2op $ ldRegFromImm setC               -- LD C,n
  , rr2op $ rotA Right true                 -- RRC A

                                            -- 1x
  , stop                                    -- STOP
  , mr2op $ ldTwoRegsFromImm setD setE      -- LD DE,nn
  , mm2op $ ldMem2RFromReg d e a            -- LD (DE),A
  , rr2op $ incRegWithCarry d e setD setE   -- INC DE

  , rr2op $ incReg d setD                   -- INC D
  , rr2op $ decReg d setD                   -- DEC D
  , mr2op $ ldRegFromImm setD               -- LD D,n
  , rr2op $ rotA Left false                 -- RL A

  , mr2op $ jumpRelImm                      -- JR n
  , rr2op $ add2RegsToHL d e                -- ADD HL,DE
  , mr2op $ ldRegFromMem2R setA d e         -- LD A,(DE)
  , rr2op $ decRegWithCarry d e setD setE   -- DEC DE

  , rr2op $ incReg e setE                   -- INC E
  , rr2op $ decReg e setE                   -- DEC E
  , mr2op $ ldRegFromImm setE               -- LD E,n
  , rr2op $ rotA Right false                -- RR A

  , rr2op $ incReg e setE                   -- INC E
  , rr2op $ decReg e setE                   -- DEC E
  , mr2op $ ldRegFromImm setE               -- LD E,n
  , rr2op $ rotA Right false                -- RR A

                                            -- 2x
  , mr2op $ jumpRelImmFlag true zeroFlag    -- JR NZ,n
  , mr2op $ ldTwoRegsFromImm setH setL      -- LD HL,nn
  , mm2op $ ldMemHLFromRegInc a             -- LDI (HL),A
  , rr2op $ incRegWithCarry h l setH setL   -- INC HL

  , rr2op $ incReg h setH                   -- INC H
  , rr2op $ decReg h setH                   -- DEC H
  , mr2op $ ldRegFromImm setH               -- LD H,n
  , rr2op $ adjAForBCDAdd                   -- DAA

  , mr2op $ jumpRelImmFlag false zeroFlag   -- JR Z,n
  , rr2op $ add2RegsToHL h l                -- ADD HL,HL
  , mr2op $ ldRegFromMemHLInc setA          -- LDI A,(HL)
  , rr2op $ decRegWithCarry h l setH setL   -- DEC HL

  , rr2op $ incReg l setL                   -- INC L
  , rr2op $ decReg l setL                   -- DEC L
  , mr2op $ ldRegFromImm setL               -- LD L,n
  , rr2op $ cmplA                           -- CPL

                                            -- 3x
  , mr2op $ jumpRelImmFlag true carryFlag   -- JR NC,n
  , mr2op $ ldSPFromImm                     -- LD SP,nn
  , mm2op $ ldMemHLFromRegDec a             -- LDD (HL),A
  , rr2op $ incSP                           -- INC SP

  , mm2op $ incHLMem                        -- INC (HL)
  , mm2op $ decHLMem                        -- DEC (HL)
  , mm2op $ ldMemHLFromImm                  -- LD (HL),n
  , rr2op $ setCarryFlag                    -- SCF

  , mr2op $ jumpRelImmFlag false carryFlag  -- JR C,n
  , rr2op $ addSPToHL                       -- ADD HL,SP
  , mr2op $ ldRegFromMemHLDec setA          -- LDD A,(HL)
  , rr2op $ decSP                           -- DEC SP

  , rr2op $ incReg a setA                   -- INC A
  , rr2op $ decReg a setA                   -- DEC A
  , mr2op $ ldRegFromImm setA               -- LD A,n
  , rr2op $ clearCarryFlag                  -- CCF

                                            -- 4x
  , rr2op $ ldRegFromReg setB b             -- LD B,B
  , rr2op $ ldRegFromReg setB c             -- LD B,C
  , rr2op $ ldRegFromReg setB d             -- LD B,D
  , rr2op $ ldRegFromReg setB e             -- LD B,E

  , rr2op $ ldRegFromReg setB h             -- LD B,H
  , rr2op $ ldRegFromReg setB l             -- LD B,L
  , mr2op $ ldRegFromMem2R setB h l         -- LD B,(HL)
  , rr2op $ ldRegFromReg setB a             -- LD B,A

  , rr2op $ ldRegFromReg setC b             -- LD C,B
  , rr2op $ ldRegFromReg setC c             -- LD C,C
  , rr2op $ ldRegFromReg setC d             -- LD C,D
  , rr2op $ ldRegFromReg setC e             -- LD C,E

  , rr2op $ ldRegFromReg setC h             -- LD C,H
  , rr2op $ ldRegFromReg setC l             -- LD C,L
  , mr2op $ ldRegFromMem2R setC h l         -- LD C,(HL)
  , rr2op $ ldRegFromReg setC a             -- LD C,A

                                            -- 5x
  , rr2op $ ldRegFromReg setD b             -- LD D,B
  , rr2op $ ldRegFromReg setD c             -- LD D,C
  , rr2op $ ldRegFromReg setD d             -- LD D,D
  , rr2op $ ldRegFromReg setD e             -- LD D,E

  , rr2op $ ldRegFromReg setD h             -- LD D,H
  , rr2op $ ldRegFromReg setD l             -- LD D,L
  , mr2op $ ldRegFromMem2R setD h l         -- LD D,(HL)
  , rr2op $ ldRegFromReg setD a             -- LD D,A

  , rr2op $ ldRegFromReg setE b             -- LD E,B
  , rr2op $ ldRegFromReg setE c             -- LD E,C
  , rr2op $ ldRegFromReg setE d             -- LD E,D
  , rr2op $ ldRegFromReg setE e             -- LD E,E

  , rr2op $ ldRegFromReg setE h             -- LD E,H
  , rr2op $ ldRegFromReg setE l             -- LD E,L
  , mr2op $ ldRegFromMem2R setE h l         -- LD E,(HL)
  , rr2op $ ldRegFromReg setE a             -- LD E,A

                                            -- 6x
  , rr2op $ ldRegFromReg setH b             -- LD H,B
  , rr2op $ ldRegFromReg setH c             -- LD H,C
  , rr2op $ ldRegFromReg setH d             -- LD H,D
  , rr2op $ ldRegFromReg setH e             -- LD H,E

  , rr2op $ ldRegFromReg setH h             -- LD H,H
  , rr2op $ ldRegFromReg setH l             -- LD H,L
  , mr2op $ ldRegFromMem2R setH h l         -- LD H,(HL)
  , rr2op $ ldRegFromReg setH a             -- LD H,A

  , rr2op $ ldRegFromReg setL b             -- LD L,B
  , rr2op $ ldRegFromReg setL c             -- LD L,C
  , rr2op $ ldRegFromReg setL d             -- LD L,D
  , rr2op $ ldRegFromReg setL e             -- LD L,E

  , rr2op $ ldRegFromReg setL h             -- LD L,H
  , rr2op $ ldRegFromReg setL l             -- LD L,L
  , mr2op $ ldRegFromMem2R setL h l         -- LD L,(HL)
  , rr2op $ ldRegFromReg setL a             -- LD L,A

                                            -- 7x
  , mm2op $ ldMem2RFromReg h l b            -- LD (HL),B
  , mm2op $ ldMem2RFromReg h l c            -- LD (HL),C
  , mm2op $ ldMem2RFromReg h l d            -- LD (HL),D
  , mm2op $ ldMem2RFromReg h l e            -- LD (HL),E

  , mm2op $ ldMem2RFromReg h l h            -- LD (HL),H
  , mm2op $ ldMem2RFromReg h l l            -- LD (HL),L
  , halt                                    -- HALT
  , mm2op $ ldMem2RFromReg h l a            -- LD (HL),A

  , rr2op $ ldRegFromReg setA b             -- LD A,B
  , rr2op $ ldRegFromReg setA c             -- LD A,C
  , rr2op $ ldRegFromReg setA d             -- LD A,D
  , rr2op $ ldRegFromReg setA e             -- LD A,E

  , rr2op $ ldRegFromReg setA h             -- LD A,H
  , rr2op $ ldRegFromReg setA l             -- LD A,L
  , mr2op $ ldRegFromMem2R setA h l         -- LD A,(HL)
  , rr2op $ ldRegFromReg setA a             -- LD A,A

                                            -- 8x
  , rr2op $ addRegToA b                     -- ADD A,B
  , rr2op $ addRegToA c                     -- ADD A,C
  , rr2op $ addRegToA d                     -- ADD A,D
  , rr2op $ addRegToA e                     -- ADD A,E

  , rr2op $ addRegToA h                     -- ADD A,H
  , rr2op $ addRegToA l                     -- ADD A,L
  , mr2op $ addHLMemToA                     -- ADD A,(HL)
  , rr2op $ addRegToA a                     -- ADD A,A

  , rr2op $ addRegCarryToA b                -- ADC A,B
  , rr2op $ addRegCarryToA c                -- ADC A,C
  , rr2op $ addRegCarryToA d                -- ADC A,D
  , rr2op $ addRegCarryToA e                -- ADC A,E

  , rr2op $ addRegCarryToA h                -- ADC A,H
  , rr2op $ addRegCarryToA l                -- ADC A,L
  , mr2op $ addHLMemCarryToA                -- ADC A,(HL)
  , rr2op $ addRegCarryToA a                -- ADC A,A

                                            -- 9x
  , rr2op $ subRegFromA b                   -- SUB A,B
  , rr2op $ subRegFromA c                   -- SUB A,C
  , rr2op $ subRegFromA d                   -- SUB A,D
  , rr2op $ subRegFromA e                   -- SUB A,E

  , rr2op $ subRegFromA h                   -- SUB A,H
  , rr2op $ subRegFromA l                   -- SUB A,L
  , mr2op $ subHLMemFromA                   -- SUB A,(HL)
  , rr2op $ subRegFromA a                   -- SUB A,A

  , rr2op $ subRegCarryFromA b              -- SBC A,B
  , rr2op $ subRegCarryFromA c              -- SBC A,C
  , rr2op $ subRegCarryFromA d              -- SBC A,D
  , rr2op $ subRegCarryFromA e              -- SBC A,E

  , rr2op $ subRegCarryFromA h              -- SBC A,H
  , rr2op $ subRegCarryFromA l              -- SBC A,L
  , mr2op $ subHLMemCarryFromA              -- SBC A,(HL)
  , rr2op $ subRegCarryFromA a              -- SBC A,A

                                            -- Ax
  , rr2op $ andOpRegIntoA b                 -- AND B
  , rr2op $ andOpRegIntoA c                 -- AND C
  , rr2op $ andOpRegIntoA d                 -- AND D
  , rr2op $ andOpRegIntoA e                 -- AND E

  , rr2op $ andOpRegIntoA h                 -- AND H
  , rr2op $ andOpRegIntoA l                 -- AND L
  , mr2op $ andOpHLMemIntoA                 -- AND (HL)
  , rr2op $ andOpRegIntoA a                 -- AND A

  , rr2op $ xorOpRegIntoA b                 -- XOR B
  , rr2op $ xorOpRegIntoA c                 -- XOR C
  , rr2op $ xorOpRegIntoA d                 -- XOR D
  , rr2op $ xorOpRegIntoA e                 -- XOR E

  , rr2op $ xorOpRegIntoA h                 -- XOR H
  , rr2op $ xorOpRegIntoA l                 -- XOR L
  , mr2op $ xorOpHLMemIntoA                 -- XOR (HL)
  , rr2op $ xorOpRegIntoA a                 -- XOR A

                                            -- Bx
  , rr2op $ orOpRegIntoA b                  -- OR B
  , rr2op $ orOpRegIntoA c                  -- OR C
  , rr2op $ orOpRegIntoA d                  -- OR D
  , rr2op $ orOpRegIntoA e                  -- OR E

  , rr2op $ orOpRegIntoA h                  -- OR H
  , rr2op $ orOpRegIntoA l                  -- OR L
  , mr2op $ orOpHLMemIntoA                  -- OR (HL)
  , rr2op $ orOpRegIntoA a                  -- OR A

  , rr2op $ compAToReg b                    -- CP B
  , rr2op $ compAToReg c                    -- CP C
  , rr2op $ compAToReg d                    -- CP D
  , rr2op $ compAToReg e                    -- CP E

  , rr2op $ compAToReg h                    -- CP H
  , rr2op $ compAToReg l                    -- CP L
  , mr2op $ compAToMemHL                    -- CP(HL)
  , rr2op $ compAToReg a                    -- CP A

                                            -- Cx
  , mr2op $ retFlag true zeroFlag           -- RET NZ
  , mr2op $ popReg setB setC                -- POP BC
  , mr2op $ jumpImmFlag true zeroFlag       -- JP NZ,nn
  , mr2op $ jumpImm                         -- JP nn

  , mm2op $ callImmFlag true zeroFlag       -- CALL NZ,nn
  , mm2op $ pushReg b c                     -- PUSH BC
  , mr2op $ addImmToA                       -- ADD A,n
  , mm2op $ callRoutine 0x00                -- RST 0

  , mr2op $ retFlag false zeroFlag          -- RET Z
  , mr2op $ ret                             -- RET
  , mr2op $ jumpImmFlag false zeroFlag      -- JP Z,nn
  , execExtOps extOps                       -- CB OpCode map

  , mm2op $ callImmFlag false zeroFlag      -- CALL Z,nn
  , mm2op $ callImm                         -- CALL nn
  , mr2op $ addImmCarryToA                  -- ADC A,n
  , mm2op $ callRoutine 0x08                -- RST 8

                                            -- Dx
  , mr2op $ retFlag true carryFlag          -- RET NC
  , mr2op $ popReg setD setE                -- POP DE
  , mr2op $ jumpImmFlag true carryFlag      -- JP NC,nn
  , invalidOpCode

  , mm2op $ callImmFlag true carryFlag      -- CALL NC,nn
  , mm2op $ pushReg d e                     -- PUSH DE
  , mr2op $ subImmFromA                     -- SUB A,n
  , mm2op $ callRoutine 0x10                -- RST 10

  , mr2op $ retFlag false carryFlag         -- RET C
  , mr2op $ retEnableInterrupt              -- RETI
  , mr2op $ jumpImmFlag false carryFlag     -- JP C,nn
  , invalidOpCode

  , mm2op $ callImmFlag true carryFlag      -- CALL C,nn
  , invalidOpCode
  , mr2op subImmCarryToA                    -- SBC A,n
  , mm2op $ callRoutine 0x18                -- RST 18

                                            -- Ex
  , mm2op $ ldFF00ImmMemFromReg a           -- LDH (n),A
  , mr2op $ popReg setH setL                -- POP HL
  , mm2op $ ldFF00CMemFromReg a             -- LDH (C),A
  , invalidOpCode

  , invalidOpCode
  , mm2op $ pushReg h l                     -- PUSH HL
  , mr2op andOpImmIntoA                     -- AND n
  , mm2op $ callRoutine 0x20                -- RST 20

  , mr2op addImmToSP                        -- ADD SP,d
  , rr2op jumpHL                            -- JP (HL)
  , mm2op ldMemImmFromRegA                  -- LD (nn),A
  , invalidOpCode

  , invalidOpCode
  , invalidOpCode
  , mr2op xorOpImmIntoA                     -- XOR n
  , mm2op $ callRoutine 0x28                -- RST 28

                                            -- Fx
  , mr2op $ ldRegFromFF00ImmMem setA        -- LDH A,(n)
  , mr2op $ popReg setA setF                -- POP AF
  , mr2op $ ldRegFromFF00CMem setA          -- LD A,(IOC)
  , rr2op $ setInterrupts false             -- DI

  , invalidOpCode
  , mm2op $ pushReg a f                     -- PUSH AF
  , mr2op orOpImmIntoA                      -- OR n
  , mm2op $ callRoutine 0x30                -- RST 30

  , mr2op ldHLFromSPImm                     -- LDHL SP,d
  , rr2op ldSPFromHL                        -- LD SP,HL
  , mr2op ldRegAFromMemImm                  -- LD A,(nn)
  , rr2op $ setInterrupts true              -- EI

  , invalidOpCode
  , invalidOpCode
  , mr2op compAToImm                        -- CP n
  , mm2op $ callRoutine 0x38                -- RST 38
]


make Layer into Foldable and Traversable

module Genetics.Browser.Layer where

import Prelude

import Control.Monad.Eff (Eff)
import Data.Foldable (class Foldable, foldlDefault, foldrDefault)
import Data.Generic.Rep (class Generic)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype)
import Data.Traversable (class Traversable, sequenceDefault, traverse_)
import Graphics.Canvas as Canvas
import Unsafe.Coerce (unsafeCoerce)

type LayerPadding =
  { top  :: Number, bottom :: Number
  , left :: Number, right  :: Number }

data LayerType =
    Fixed
  | Scrolling

data LayerMask = NoMask | Masked

derive instance eqLayerMask :: Eq LayerMask

type Point = { x :: Number, y :: Number }

data Component a =
    Full   a
  | Padded Number a
  | Outside { top    :: a
            , right  :: a
            , bottom :: a
            , left   :: a }

derive instance eqComponent :: Eq a => Eq (Component a)
derive instance ordComponent :: Ord a => Ord (Component a)
derive instance functorComponent :: Functor Component
derive instance genericComponent :: Generic (Component a) _

instance foldableComponent :: Foldable Component where
  foldMap :: ∀ a m. Monoid m => (a -> m) -> Component a -> m
  foldMap f = case _ of
    Full     a -> f a
    Padded _ a -> f a
    Outside as -> f as.top <> f as.right <> f as.bottom <> f as.left

  foldr f i c = foldrDefault f i c
  foldl f i c = foldlDefault f i c

instance traverseComponent :: Traversable Component where
  traverse :: ∀ a b m. Applicative m => (a -> m b) -> Component a -> m (Component b)
  traverse f = case _ of
    Full     a -> Full <$> f a
    Padded r a -> Padded r <$> f a
    Outside as ->
      (\t r b l -> Outside {top: t, right: r, bottom: b, left: l})
      <$> f as.top
      <*> f as.right
      <*> f as.bottom
      <*> f as.left

  sequence t = sequenceDefault t

data Layer a = Layer LayerType LayerMask (Component a)

type LayerDimensions =
  { size    :: Canvas.Dimensions
  , padding :: LayerPadding }

type ComponentSlot = { offset :: Point
                     , size   :: Canvas.Dimensions }

type CanvasComponent a = Component (ComponentSlot -> a)

type LayerSlots a =
  ( full   :: a
  , padded :: a
  , top    :: a
  , right  :: a
  , bottom :: a
  , left   :: a )

layerSlots :: LayerDimensions
           -> Record (LayerSlots ComponentSlot)
layerSlots {size,padding} =
  let p0 = { x: 0.0, y: 0.0 }
      w  = size.width
      h  = size.height
      wC = w - padding.right - padding.left
      full   = { offset: p0
               , size }
      left   = { offset: p0
               , size: { width:  padding.left
                       , height: h
                       } }
      right  = { offset: p0 { x = w - padding.right }
               , size: { width:  padding.right
                       , height: h
                       } }
      top    = { offset: p0 { x = padding.left }
               , size: { width:  wC
                       , height: padding.top
                       } }
      bottom = { offset: { x:     padding.left
                         , y: h - padding.bottom }
               , size: { width:  wC
                       , height: padding.bottom
                       } }
      padded = { offset: { x: padding.left
                         , y: padding.top }
               , size: { width:  wC
                       , height: h - padding.top - padding.bottom
                       } }
  in { full, padded, top, right, bottom, left }

drawComponent :: ∀ a.
                 LayerDimensions
              -> Component (ComponentSlot -> a)
              -> Component a
drawComponent ld =
  let dims = layerSlots ld
  in case _ of
    Full     f -> Full     $ f dims.full
    Padded p f -> Padded p $ f dims.padded
    Outside  f -> Outside  $ { top:    f.top    dims.top
                             , right:  f.right  dims.right
                             , bottom: f.bottom dims.bottom
                             , left:   f.left   dims.left }

module Genetics.Browser.Layer where

import Prelude

import Control.Monad.Eff (Eff)
import Data.Foldable (class Foldable)
import Data.Generic.Rep (class Generic)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype)
import Data.Traversable (class Traversable, traverse_)
import Graphics.Canvas as Canvas
import Unsafe.Coerce (unsafeCoerce)

type LayerPadding =
  { top  :: Number, bottom :: Number
  , left :: Number, right  :: Number }

data LayerType =
    Fixed
  | Scrolling

data LayerMask = NoMask | Masked

type Point = { x :: Number, y :: Number }

data Component a =
    Full   a
  | Padded Number a
  | Outside { top    :: a
            , right  :: a
            , bottom :: a
            , left   :: a }

derive instance eqComponent :: Eq a => Eq (Component a)
derive instance ordComponent :: Ord a => Ord (Component a)
derive instance functorComponent :: Functor Component
derive instance genericComponent :: Generic (Component a) _

data Layer a = Layer LayerType LayerMask (Component a)

type LayerDimensions =
  { size    :: Canvas.Dimensions
  , padding :: LayerPadding }

type ComponentSlot = { offset :: Point
                     , size   :: Canvas.Dimensions }

type CanvasComponent a = Component (ComponentSlot -> a)

type LayerSlots a =
  ( full   :: a
  , padded :: a
  , top    :: a
  , right  :: a
  , bottom :: a
  , left   :: a )

layerSlots :: LayerDimensions
           -> Record (LayerSlots ComponentSlot)
layerSlots {size,padding} =
  let p0 = { x: 0.0, y: 0.0 }
      w  = size.width
      h  = size.height
      wC = w - padding.right - padding.left
      full   = { offset: p0
               , size }
      left   = { offset: p0
               , size: { width:  padding.left
                       , height: h
                       } }
      right  = { offset: p0 { x = w - padding.right }
               , size: { width:  padding.right
                       , height: h
                       } }
      top    = { offset: p0 { x = padding.left }
               , size: { width:  wC
                       , height: padding.top
                       } }
      bottom = { offset: { x:     padding.left
                         , y: h - padding.bottom }
               , size: { width:  wC
                       , height: padding.bottom
                       } }
      padded = { offset: { x: padding.left
                         , y: padding.top }
               , size: { width:  wC
                       , height: h - padding.top - padding.bottom
                       } }
  in { full, padded, top, right, bottom, left }

drawComponent :: ∀ a.
                 LayerDimensions
              -> Component (ComponentSlot -> a)
              -> Component a
drawComponent ld =
  let dims = layerSlots ld
  in case _ of
    Full     f -> Full     $ f dims.full
    Padded p f -> Padded p $ f dims.padded
    Outside  f -> Outside  $ { top:    f.top    dims.top
                             , right:  f.right  dims.right
                             , bottom: f.bottom dims.bottom
                             , left:   f.left   dims.left }


Update code style to match other dialogs

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.FileSystem.Dialog.Mount.SQL2.Component
  ( comp
  , Query
  , module SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery
  , module MCS
  ) where

import SlamData.Prelude

import Data.Array (filter)
import Data.Path.Pathy as Pt
import Data.StrMap as Sm

import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Halogen.Component (AceQuery(..), Autocomplete(..), aceComponent)
import Ace.Types (Editor)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Elements.Keyed as HHEK

import SlamData.Monad (Slam)
import SlamData.FileSystem.Dialog.Mount.Common.Render (propList, section)
import SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery (SettingsQuery(..), SettingsMessage(..))
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State as MCS
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Query as API

type Query = SettingsQuery MCS.State

comp ∷ MCS.State → H.Component HH.HTML Query Unit SettingsMessage Slam
comp initialState =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ MCS.State → H.ParentHTML Query AceQuery Unit Slam
render state@{ initialQuery } =
  HHEK.div_
    [ "mount-sql2-query" × section "SQL² query"
        [ HH.slot
            unit
            (aceComponent (aceSetup initialQuery) (Just Live))
            unit
            (const (Just (H.action (ModifyState id))))
        ]
    , "mount-sql2-vars" × section "Query variables" [ propList MCS._vars state ]
    ]

eval ∷ Query ~> H.ParentDSL MCS.State Query AceQuery Unit SettingsMessage Slam
eval = case _ of
  ModifyState f next → do
    H.modify (MCS.processState <<< f)
    H.raise Modified
    pure next
  Validate k → do
    sql ← fromMaybe "" <$> H.query unit (H.request GetText)
    pure $ k if sql == "" then Just "Please enter a query" else Nothing
  Submit parent name k → do
    sql ← fromMaybe "" <$> H.query unit (H.request GetText)
    vars ← Sm.fromFoldable <<< filter (not MCS.isEmptyVar) <$> H.gets _.vars
    let destPath = parent Pt.</> Pt.file name
        view = R.View $ destPath
        dest = R.Mount view
    result ← API.viewQuery (Left parent) destPath sql vars
    pure $ k $ map (const view) result

aceSetup ∷ Maybe String → Editor → Slam Unit
aceSetup initialQuery editor = H.liftEff do
  Editor.setMinLines 6 editor
  Editor.setMaxLines 10000 editor
  Editor.setAutoScrollEditorIntoView true editor
  Editor.setTheme "ace/theme/chrome" editor
  Editor.setEnableLiveAutocompletion true editor
  Editor.setEnableBasicAutocompletion true editor
  session ← Editor.getSession editor
  Session.setMode "ace/mode/sql" session
  case initialQuery of
    Just q → void $ Editor.setValue q Nothing editor
    Nothing → pure unit

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.FileSystem.Dialog.Mount.SQL2.Component
  ( comp
  , Query
  , module SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery
  , module SlamData.FileSystem.Dialog.Mount.SQL2.Component.State
  ) where

import SlamData.Prelude

import Data.Array (filter)
import Data.Path.Pathy as Pt
import Data.StrMap as Sm

import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Halogen.Component (AceQuery(..), Autocomplete(..), aceComponent)
import Ace.Types (Editor)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Elements.Keyed as HHEK

import SlamData.Monad (Slam)
import SlamData.FileSystem.Dialog.Mount.Common.Render (propList, section)
import SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery (SettingsQuery(..), SettingsMessage(..))
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State (State, _initialQuery, _vars, emptyVar, isEmptyVar, processState, rxEmpty, stateFromViewInfo)
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Query as API

type Query = SettingsQuery State

comp ∷ State → H.Component HH.HTML Query Unit SettingsMessage Slam
comp initialState =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → H.ParentHTML Query AceQuery Unit Slam
render state@{ initialQuery } =
  HHEK.div_
    [ "mount-sql2-query" × section "SQL² query"
        [ HH.slot
            unit
            (aceComponent (aceSetup initialQuery) (Just Live))
            unit
            (const (Just (H.action (ModifyState id))))
        ]
    , "mount-sql2-vars" × section "Query variables" [ propList _vars state ]
    ]

eval ∷ Query ~> H.ParentDSL State Query AceQuery Unit SettingsMessage Slam
eval (ModifyState f next) = do
  H.modify (processState <<< f)
  H.raise Modified
  pure next
eval (Validate k) = do
  sql ← fromMaybe "" <$> H.query unit (H.request GetText)
  pure $ k if sql == "" then Just "Please enter a query" else Nothing
eval (Submit parent name k) = do
  sql ← fromMaybe "" <$> H.query unit (H.request GetText)
  vars ← Sm.fromFoldable <<< filter (not isEmptyVar) <$> H.gets _.vars
  let destPath = parent Pt.</> Pt.file name
      view = R.View $ destPath
      dest = R.Mount view
  result ← API.viewQuery (Left parent) destPath sql vars
  pure $ k $ map (const view) result

aceSetup ∷ Maybe String → Editor → Slam Unit
aceSetup initialQuery editor = H.liftEff do
  Editor.setMinLines 6 editor
  Editor.setMaxLines 10000 editor
  Editor.setAutoScrollEditorIntoView true editor
  Editor.setTheme "ace/theme/chrome" editor
  Editor.setEnableLiveAutocompletion true editor
  Editor.setEnableBasicAutocompletion true editor
  session ← Editor.getSession editor
  Session.setMode "ace/mode/sql" session
  case initialQuery of
    Just q → void $ Editor.setValue q Nothing editor
    Nothing → pure unit