Restore compiler-optimized TCO for span

Restore compiler-optimized TCO for span

-- | 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
  , mapMaybe
  , catMaybes
  , mapWithIndex

  , sort
  , sortBy
  , sortWith
  , 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. Unfoldable f => Array ~> f
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. Foldable f => f ~> Array
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))

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

-- | Sort the elements of an array in increasing order, where elements are
-- | sorted based on a projection
sortWith :: forall a b. Ord b => (a -> b) -> Array a -> Array a
sortWith f = sortBy (comparing f)

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
  , mapMaybe
  , catMaybes
  , mapWithIndex

  , sort
  , sortBy
  , sortWith
  , 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, tailRec)
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. Unfoldable f => Array ~> f
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. Foldable f => f ~> Array
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))

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

-- | Sort the elements of an array in increasing order, where elements are
-- | sorted based on a projection
sortWith :: forall a b. Ord b => (a -> b) -> Array a -> Array a
sortWith f = sortBy (comparing f)

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 = tailRec \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 Loop (i + 1) else Done (Just i)
      Nothing -> Done 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


Ignore return value of `Node.Stream.writeString`

From Node.Stream.writeString docs:

  "Returns false if the stream wishes for the calling code to wait for the 'drain' event to be emitted before continuing to write additional data; otherwise true."

So it seems that it is enough to just wait till writing has finished which is done by our Aff continuation.
I'm not sure but situation can be a bit more complicated if we take
Aff Fibers into account and consider other "concurrent" writes...

module Hyper.Node.Server
       ( HttpRequest
       , HttpResponse
       , NodeResponse
       , writeString
       , write
       , module Hyper.Node.Server.Options
       , runServer
       , runServer'
       ) where

import Prelude

import Control.IxMonad (ipure, (:*>), (:>>=))
import Control.Monad.Aff (Aff, launchAff, launchAff_, makeAff, nonCanceler, runAff_)
import Control.Monad.Aff.AVar (AVAR, makeEmptyVar, makeVar, putVar, takeVar)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (EXCEPTION, catchException)
import Control.Monad.Error.Class (throwError)
import Data.Either (Either(..), either)
import Data.HTTP.Method as Method
import Data.Int as Int
import Data.Lazy (defer)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.StrMap as StrMap
import Data.Tuple (Tuple(..))
import Hyper.Conn (Conn)
import Hyper.Middleware (Middleware, evalMiddleware, lift')
import Hyper.Middleware.Class (getConn, modifyConn)
import Hyper.Node.Server.Options (Options)
import Hyper.Node.Server.Options as Hyper.Node.Server.Options
import Hyper.Request (class ReadableBody, class Request, class StreamableBody, RequestData, parseUrl, readBody)
import Hyper.Response (class ResponseWritable, class Response, ResponseEnded, StatusLineOpen)
import Hyper.Status (Status(..))
import Node.Buffer (BUFFER, Buffer)
import Node.Buffer as Buffer
import Node.Encoding (Encoding(..))
import Node.HTTP (HTTP)
import Node.HTTP as HTTP
import Node.Stream (Stream, Writable)
import Node.Stream as Stream

data HttpRequest
  = HttpRequest HTTP.Request RequestData

instance requestHttpRequest :: Monad m => Request HttpRequest m where
  getRequestData = do
    getConn :>>=
    case _ of
      { request: HttpRequest _ d } -> ipure d

-- A limited version of Writable () e, with which you can only write, not end,
-- the Stream.
newtype NodeResponse m e
  = NodeResponse (Writable () e -> m Unit)

writeString :: forall m e. MonadAff e m => Encoding -> String -> NodeResponse m e
writeString enc str = NodeResponse $ \w ->
  liftAff (makeAff (\k -> Stream.writeString w enc str (k (pure unit))
                          *> pure nonCanceler))

write :: forall m e. MonadAff e m => Buffer -> NodeResponse m e
write buffer = NodeResponse $ \w ->
  liftAff (makeAff (\k -> Stream.write w buffer (k (pure unit))
                          *> pure nonCanceler))

instance stringNodeResponse :: (MonadAff e m) => ResponseWritable (NodeResponse m e) m String where
  toResponse = ipure <<< writeString UTF8

instance stringAndEncodingNodeResponse :: (MonadAff e m) => ResponseWritable (NodeResponse m e) m (Tuple String Encoding) where
  toResponse (Tuple body encoding) =
    ipure (writeString encoding body)

instance bufferNodeResponse :: (MonadAff e m)
                                  => ResponseWritable (NodeResponse m e) m Buffer where
  toResponse buf =
    ipure (write buf)

-- Helper function that reads a Stream into a Buffer, and throws error
-- in `Aff` when failed.
readBodyAsBuffer
  :: forall e.
     HttpRequest
  -> Aff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) Buffer
readBodyAsBuffer (HttpRequest request _) = do
  let stream = HTTP.requestAsStream request
  bodyResult <- makeEmptyVar
  chunks <- makeVar []
  fillResult <- liftEff $
    catchException (pure <<< Left) (Right <$> fillBody stream chunks bodyResult)
  -- Await the body, or an error.
  body <- takeVar bodyResult
  -- Return the body, if neither `fillResult` nor `body` is a `Left`.
  either throwError pure (fillResult *> body)
  where
    fillBody stream chunks bodyResult = do
      -- Append all chunks to the body buffer.
      Stream.onData stream \chunk ->
        let modification = do
              v <- takeVar chunks
              putVar (v <> [chunk]) chunks
        in void (launchAff modification)
      -- Complete with `Left` on error.
      Stream.onError stream $
        launchAff_ <<< flip putVar bodyResult <<< Left
      -- Complete with `Right` on successful "end" event.
      Stream.onEnd stream $ void $ launchAff $
        takeVar chunks
        >>= concat'
        >>= (pure <<< Right)
        >>= flip putVar bodyResult
    concat' = liftEff <<< Buffer.concat

instance readableBodyHttpRequestString :: (Monad m, MonadAff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) m)
                                       => ReadableBody HttpRequest m String where
  readBody =
    readBody :>>= (liftEff <<< Buffer.toString UTF8)

instance readableBodyHttpRequestBuffer :: (Monad m, MonadAff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) m)
                                       => ReadableBody HttpRequest m Buffer where
  readBody =
    _.request <$> getConn :>>=
    case _ of
      r -> liftAff (readBodyAsBuffer r)

instance streamableBodyHttpRequestReadable :: MonadAff (http :: HTTP | e) m
                                           => StreamableBody
                                              HttpRequest
                                              m
                                              (Stream (read :: Stream.Read) (http :: HTTP, exception :: EXCEPTION | e)) where
  streamBody =
    _.request <$> getConn :>>=
    case _ of
      HttpRequest request _ -> ipure (HTTP.requestAsStream request)

-- TODO: Make a newtype
data HttpResponse state = HttpResponse HTTP.Response

getWriter ∷ ∀ req res c m rw.
            Monad m ⇒
            Middleware
            m
            (Conn req { writer ∷ rw | res } c)
            (Conn req { writer ∷ rw | res } c)
            rw
getWriter = _.response.writer <$> getConn

setStatus ∷ ∀ req res c m e.
            MonadEff (http ∷ HTTP | e) m
          ⇒ Status
          → HTTP.Response
          → Middleware m (Conn req res c) (Conn req res c) Unit
setStatus (Status { code, reasonPhrase }) r = liftEff do
  HTTP.setStatusCode r code
  HTTP.setStatusMessage r reasonPhrase

writeHeader' ∷ ∀ req res c m e.
               MonadEff (http ∷ HTTP | e) m
             ⇒ (Tuple String String)
             → HTTP.Response
             → Middleware m (Conn req res c) (Conn req res c) Unit
writeHeader' (Tuple name value) r =
  liftEff $ HTTP.setHeader r name value

writeResponse ∷ ∀ req res c m e.
                MonadAff (http ∷ HTTP | e) m
             ⇒ HTTP.Response
             → NodeResponse m (http :: HTTP | e)
             → Middleware m (Conn req res c) (Conn req res c) Unit
writeResponse r (NodeResponse f) =
  lift' (f (HTTP.responseAsStream r))

endResponse ∷ ∀ req res c m e.
              MonadEff (http ∷ HTTP | e) m
            ⇒ HTTP.Response
            → Middleware m (Conn req res c) (Conn req res c) Unit
endResponse r =
  liftEff (Stream.end (HTTP.responseAsStream r) (pure unit))

instance responseWriterHttpResponse :: MonadAff (http ∷ HTTP | e) m
                                    => Response HttpResponse m (NodeResponse m (http :: HTTP | e)) where
  writeStatus status =
    getConn :>>= \{ response: HttpResponse r } ->
      setStatus status r
      :*> modifyConn (_ { response = HttpResponse r })

  writeHeader header =
    getConn :>>= \{ response: HttpResponse r } ->
      writeHeader' header r
      :*> modifyConn (_ { response = HttpResponse r })

  closeHeaders =
    getConn :>>= \{ response: HttpResponse r } ->
      modifyConn (_ { response = HttpResponse r })

  send f =
    getConn :>>= \{ response: HttpResponse r } ->
      writeResponse r f
      :*> modifyConn (_ { response = HttpResponse r })

  end =
    getConn :>>= \{ response: HttpResponse r } ->
      endResponse r
      :*> modifyConn (_ { response = HttpResponse r })

mkHttpRequest :: HTTP.Request -> HttpRequest
mkHttpRequest request =
  HttpRequest request requestData
  where
    headers = HTTP.requestHeaders request
    requestData =
      { url: HTTP.requestURL request
      , parsedUrl: defer \_ -> parseUrl (HTTP.requestURL request)
      , headers: headers
      , method: Method.fromString (HTTP.requestMethod request)
      , contentLength: StrMap.lookup "content-length" headers
                      >>= Int.fromString
      }

runServer'
  :: forall m e c c'
   . Functor m
  => Options e
  -> c
  -> (forall a. m a -> Aff (http :: HTTP | e) a)
  -> Middleware
     m
     (Conn HttpRequest (HttpResponse StatusLineOpen) c)
     (Conn HttpRequest (HttpResponse ResponseEnded) c')
     Unit
  -> Eff (http :: HTTP | e) Unit
runServer' options components runM middleware = do
  server <- HTTP.createServer onRequest
  let listenOptions = { port: unwrap options.port
                      , hostname: unwrap options.hostname
                      , backlog: Nothing
                      }
  HTTP.listen server listenOptions (options.onListening options.hostname options.port)
  where
    onRequest ∷ HTTP.Request → HTTP.Response → Eff (http :: HTTP | e) Unit
    onRequest request response =
      let conn = { request: mkHttpRequest request
                 , response: HttpResponse response
                 , components: components
                 }
          callback =
            case _ of
              Left err -> options.onRequestError err
              Right _ -> pure unit
      in conn
         # evalMiddleware middleware
         # runM
         # runAff_ callback

runServer
  :: forall e c c'.
     Options e
  -> c
  -> Middleware
     (Aff (http :: HTTP | e))
     (Conn HttpRequest (HttpResponse StatusLineOpen) c)
     (Conn HttpRequest (HttpResponse ResponseEnded) c')
     Unit
  -> Eff (http :: HTTP | e) Unit
runServer options components middleware =
  runServer' options components id middleware

module Hyper.Node.Server
       ( HttpRequest
       , HttpResponse
       , NodeResponse
       , writeString
       , write
       , module Hyper.Node.Server.Options
       , runServer
       , runServer'
       ) where

import Prelude

import Control.IxMonad (ipure, (:*>), (:>>=))
import Control.Monad.Aff (Aff, launchAff, launchAff_, makeAff, nonCanceler, runAff_)
import Control.Monad.Aff.AVar (AVAR, makeEmptyVar, makeVar, putVar, takeVar)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (EXCEPTION, catchException, error)
import Control.Monad.Error.Class (throwError)
import Data.Either (Either(..), either)
import Data.HTTP.Method as Method
import Data.Int as Int
import Data.Lazy (defer)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.StrMap as StrMap
import Data.Tuple (Tuple(..))
import Hyper.Conn (Conn)
import Hyper.Middleware (Middleware, evalMiddleware, lift')
import Hyper.Middleware.Class (getConn, modifyConn)
import Hyper.Node.Server.Options (Options)
import Hyper.Node.Server.Options as Hyper.Node.Server.Options
import Hyper.Request (class ReadableBody, class Request, class StreamableBody, RequestData, parseUrl, readBody)
import Hyper.Response (class ResponseWritable, class Response, ResponseEnded, StatusLineOpen)
import Hyper.Status (Status(..))
import Node.Buffer (BUFFER, Buffer)
import Node.Buffer as Buffer
import Node.Encoding (Encoding(..))
import Node.HTTP (HTTP)
import Node.HTTP as HTTP
import Node.Stream (Stream, Writable)
import Node.Stream as Stream

data HttpRequest
  = HttpRequest HTTP.Request RequestData

instance requestHttpRequest :: Monad m => Request HttpRequest m where
  getRequestData = do
    getConn :>>=
    case _ of
      { request: HttpRequest _ d } -> ipure d

-- A limited version of Writable () e, with which you can only write, not end,
-- the Stream.
newtype NodeResponse m e
  = NodeResponse (Writable () e -> m Unit)

writeString :: forall m e. MonadAff e m => Encoding -> String -> NodeResponse m e
writeString enc str = NodeResponse $ \w -> liftAff (makeAff (writeAsAff w))
  where
    writeAsAff w k = do
      Stream.writeString w enc str (k (pure unit)) >>=
      if _
        then k (pure unit)
        else k (throwError (error "Failed to write string to response"))
      pure nonCanceler

write :: forall m e. MonadAff e m => Buffer -> NodeResponse m e
write buffer = NodeResponse $ \w ->
  liftAff (makeAff (\k -> Stream.write w buffer (k (pure unit))
                          *> pure nonCanceler))

instance stringNodeResponse :: (MonadAff e m) => ResponseWritable (NodeResponse m e) m String where
  toResponse = ipure <<< writeString UTF8

instance stringAndEncodingNodeResponse :: (MonadAff e m) => ResponseWritable (NodeResponse m e) m (Tuple String Encoding) where
  toResponse (Tuple body encoding) =
    ipure (writeString encoding body)

instance bufferNodeResponse :: (MonadAff e m)
                                  => ResponseWritable (NodeResponse m e) m Buffer where
  toResponse buf =
    ipure (write buf)

-- Helper function that reads a Stream into a Buffer, and throws error
-- in `Aff` when failed.
readBodyAsBuffer
  :: forall e.
     HttpRequest
  -> Aff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) Buffer
readBodyAsBuffer (HttpRequest request _) = do
  let stream = HTTP.requestAsStream request
  bodyResult <- makeEmptyVar
  chunks <- makeVar []
  fillResult <- liftEff $
    catchException (pure <<< Left) (Right <$> fillBody stream chunks bodyResult)
  -- Await the body, or an error.
  body <- takeVar bodyResult
  -- Return the body, if neither `fillResult` nor `body` is a `Left`.
  either throwError pure (fillResult *> body)
  where
    fillBody stream chunks bodyResult = do
      -- Append all chunks to the body buffer.
      Stream.onData stream \chunk ->
        let modification = do
              v <- takeVar chunks
              putVar (v <> [chunk]) chunks
        in void (launchAff modification)
      -- Complete with `Left` on error.
      Stream.onError stream $
        launchAff_ <<< flip putVar bodyResult <<< Left
      -- Complete with `Right` on successful "end" event.
      Stream.onEnd stream $ void $ launchAff $
        takeVar chunks
        >>= concat'
        >>= (pure <<< Right)
        >>= flip putVar bodyResult
    concat' = liftEff <<< Buffer.concat

instance readableBodyHttpRequestString :: (Monad m, MonadAff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) m)
                                       => ReadableBody HttpRequest m String where
  readBody =
    readBody :>>= (liftEff <<< Buffer.toString UTF8)

instance readableBodyHttpRequestBuffer :: (Monad m, MonadAff (http :: HTTP, avar :: AVAR, buffer :: BUFFER | e) m)
                                       => ReadableBody HttpRequest m Buffer where
  readBody =
    _.request <$> getConn :>>=
    case _ of
      r -> liftAff (readBodyAsBuffer r)

instance streamableBodyHttpRequestReadable :: MonadAff (http :: HTTP | e) m
                                           => StreamableBody
                                              HttpRequest
                                              m
                                              (Stream (read :: Stream.Read) (http :: HTTP, exception :: EXCEPTION | e)) where
  streamBody =
    _.request <$> getConn :>>=
    case _ of
      HttpRequest request _ -> ipure (HTTP.requestAsStream request)

-- TODO: Make a newtype
data HttpResponse state = HttpResponse HTTP.Response

getWriter ∷ ∀ req res c m rw.
            Monad m ⇒
            Middleware
            m
            (Conn req { writer ∷ rw | res } c)
            (Conn req { writer ∷ rw | res } c)
            rw
getWriter = _.response.writer <$> getConn

setStatus ∷ ∀ req res c m e.
            MonadEff (http ∷ HTTP | e) m
          ⇒ Status
          → HTTP.Response
          → Middleware m (Conn req res c) (Conn req res c) Unit
setStatus (Status { code, reasonPhrase }) r = liftEff do
  HTTP.setStatusCode r code
  HTTP.setStatusMessage r reasonPhrase

writeHeader' ∷ ∀ req res c m e.
               MonadEff (http ∷ HTTP | e) m
             ⇒ (Tuple String String)
             → HTTP.Response
             → Middleware m (Conn req res c) (Conn req res c) Unit
writeHeader' (Tuple name value) r =
  liftEff $ HTTP.setHeader r name value

writeResponse ∷ ∀ req res c m e.
                MonadAff (http ∷ HTTP | e) m
             ⇒ HTTP.Response
             → NodeResponse m (http :: HTTP | e)
             → Middleware m (Conn req res c) (Conn req res c) Unit
writeResponse r (NodeResponse f) =
  lift' (f (HTTP.responseAsStream r))

endResponse ∷ ∀ req res c m e.
              MonadEff (http ∷ HTTP | e) m
            ⇒ HTTP.Response
            → Middleware m (Conn req res c) (Conn req res c) Unit
endResponse r =
  liftEff (Stream.end (HTTP.responseAsStream r) (pure unit))

instance responseWriterHttpResponse :: MonadAff (http ∷ HTTP | e) m
                                    => Response HttpResponse m (NodeResponse m (http :: HTTP | e)) where
  writeStatus status =
    getConn :>>= \{ response: HttpResponse r } ->
      setStatus status r
      :*> modifyConn (_ { response = HttpResponse r })

  writeHeader header =
    getConn :>>= \{ response: HttpResponse r } ->
      writeHeader' header r
      :*> modifyConn (_ { response = HttpResponse r })

  closeHeaders =
    getConn :>>= \{ response: HttpResponse r } ->
      modifyConn (_ { response = HttpResponse r })

  send f =
    getConn :>>= \{ response: HttpResponse r } ->
      writeResponse r f
      :*> modifyConn (_ { response = HttpResponse r })

  end =
    getConn :>>= \{ response: HttpResponse r } ->
      endResponse r
      :*> modifyConn (_ { response = HttpResponse r })

mkHttpRequest :: HTTP.Request -> HttpRequest
mkHttpRequest request =
  HttpRequest request requestData
  where
    headers = HTTP.requestHeaders request
    requestData =
      { url: HTTP.requestURL request
      , parsedUrl: defer \_ -> parseUrl (HTTP.requestURL request)
      , headers: headers
      , method: Method.fromString (HTTP.requestMethod request)
      , contentLength: StrMap.lookup "content-length" headers
                      >>= Int.fromString
      }

runServer'
  :: forall m e c c'
   . Functor m
  => Options e
  -> c
  -> (forall a. m a -> Aff (http :: HTTP | e) a)
  -> Middleware
     m
     (Conn HttpRequest (HttpResponse StatusLineOpen) c)
     (Conn HttpRequest (HttpResponse ResponseEnded) c')
     Unit
  -> Eff (http :: HTTP | e) Unit
runServer' options components runM middleware = do
  server <- HTTP.createServer onRequest
  let listenOptions = { port: unwrap options.port
                      , hostname: unwrap options.hostname
                      , backlog: Nothing
                      }
  HTTP.listen server listenOptions (options.onListening options.hostname options.port)
  where
    onRequest ∷ HTTP.Request → HTTP.Response → Eff (http :: HTTP | e) Unit
    onRequest request response =
      let conn = { request: mkHttpRequest request
                 , response: HttpResponse response
                 , components: components
                 }
          callback =
            case _ of
              Left err -> options.onRequestError err
              Right _ -> pure unit
      in conn
         # evalMiddleware middleware
         # runM
         # runAff_ callback

runServer
  :: forall e c c'.
     Options e
  -> c
  -> Middleware
     (Aff (http :: HTTP | e))
     (Conn HttpRequest (HttpResponse StatusLineOpen) c)
     (Conn HttpRequest (HttpResponse ResponseEnded) c')
     Unit
  -> Eff (http :: HTTP | e) Unit
runServer options components middleware =
  runServer' options components id middleware


responds to arrow keys

responds to arrow keys

module Main where

import Prelude
import Data.Maybe

import Graphics.Canvas
import DOM.Timer
import Control.Monad.Eff
import Control.Monad.ST
import Control.Monad.Eff.JQuery hiding (append)
import Control.Monad.Eff.Console
import DOM

foreign import jqwhich :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) Int

data Direction = Left | Up | Right | Down

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

type GameState =
  { x :: Number
  , y :: Number
  , w :: Number
  , h :: Number
  , dir :: Direction
  }

directionToMove :: Direction -> Move
directionToMove Left =  { x: -1.0, y:  0.0 }
directionToMove Up =    { x:  0.0, y: -1.0 }
directionToMove Right = { x:  1.0, y:  0.0 }
directionToMove Down  = { x:  0.0, y:  1.0 }

initialState :: GameState
initialState = { x: (areaSize / 2.0) - (bitSize / 2.0)
               , y: (areaSize / 2.0) - (bitSize / 2.0)
               , w: bitSize
               , h: bitSize
               , dir: Down
               }

areaSize = 100.0
sqSize = areaSize / 5.0
bitSize = sqSize - 2.0

moveSnake :: GameState -> GameState
moveSnake state = { x: state.x + (mv.x * sqSize)
                  , y: state.y + (mv.y * sqSize)
                  , w: state.w
                  , h: state.h
                  , dir: state.dir
                  }
  where
    mv = directionToMove state.dir

main :: forall h. Eff (canvas :: Canvas, st :: ST h, timer :: Timer, dom :: DOM, console :: CONSOLE) Unit
main = do
  Just canvas <- getCanvasElementById "canvas"
  dim <- getCanvasDimensions canvas
  ctx <- getContext2D canvas

  st <- newSTRef initialState

  body <- body
  on "keydown" (onKey st) body

  inter <- interval 100 $ do
    st2 <- readSTRef st
    setFillStyle "#FF0000" ctx
    fillPath ctx $ rect ctx { x:0.0, y:0.0, w:dim.width, h:dim.height }
    setFillStyle "#0000FF" ctx
    fillPath ctx $ rect ctx { x:st2.x, y:st2.y, w:st2.w, h:st2.h }
    modifySTRef st \st1 -> moveSnake st1
    return unit
  return unit

onKey :: forall eff a h r. (STRef h GameState) -> JQueryEvent -> JQuery -> Eff (dom :: DOM, console :: CONSOLE, st :: ST h | eff) GameState
onKey mystate evt _ = do
  code <- jqwhich evt
  modifySTRef mystate \cur -> cur { dir = case code of
                                       37 -> Left
                                       38 -> Up
                                       39 -> Right
                                       40 -> Down }

-- make it grow with food, some random place ment
-- performance is funny
-- need an easy way to compile it and open in a browser
-- compile means pulp browserify > and then open something
  -- would be nice to have some sort of project thing I can think about that

module Main where

import Prelude
import Data.Maybe

import Graphics.Canvas
import DOM.Timer
import Control.Monad.Eff
import Control.Monad.ST
import Control.Monad.Eff.JQuery hiding (append)
import Control.Monad.Eff.Console
import DOM

foreign import jqwhich :: forall eff. JQueryEvent -> Eff (dom :: DOM | eff) String

data Direction = Left | Up | Right | Down

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

type GameState =
  { x :: Number
  , y :: Number
  , w :: Number
  , h :: Number
  , dir :: Direction
  }

directionToMove :: Direction -> Move
directionToMove Left =  { x: -1.0, y:  0.0 }
directionToMove Up =    { x:  0.0, y: -1.0 }
directionToMove Right = { x:  1.0, y:  0.0 }
directionToMove Down  = { x:  0.0, y:  1.0 }

initialState :: GameState
initialState = { x: (areaSize / 2.0) - (bitSize / 2.0)
               , y: (areaSize / 2.0) - (bitSize / 2.0)
               , w: bitSize
               , h: bitSize
               , dir: Down
               }

areaSize = 100.0
sqSize = areaSize / 5.0
bitSize = sqSize - 2.0

moveSnake :: GameState -> GameState
moveSnake state = { x: state.x + (mv.x * sqSize)
                  , y: state.y + (mv.y * sqSize)
                  , w: state.w
                  , h: state.h
                  , dir: state.dir
                  }
  where
    mv = directionToMove state.dir

main :: forall h. Eff (canvas :: Canvas, st :: ST h, timer :: Timer, dom :: DOM, console :: CONSOLE) Unit
main = do
  Just canvas <- getCanvasElementById "canvas"
  dim <- getCanvasDimensions canvas
  ctx <- getContext2D canvas

  st <- newSTRef initialState

  body <- body
  on "keydown" onKey body

  inter <- interval 500 $ do
    st2 <- readSTRef st
    setFillStyle "#FF0000" ctx
    fillPath ctx $ rect ctx { x:0.0, y:0.0, w:dim.width, h:dim.height }
    setFillStyle "#0000FF" ctx
    fillPath ctx $ rect ctx { x:st2.x, y:st2.y, w:st2.w, h:st2.h }
    modifySTRef st \st1 -> moveSnake st1
    return unit
  return unit

onKey :: forall eff a h. JQueryEvent -> JQuery -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
onKey evt _ = do
  --37 8 9 40 left up right down
  code <- jqwhich evt
  log code

-- pass in state ugh
-- now code to direction
  -- and put direction in the state
-- how do I want to modify?
-- need a way to compile it and open in a browser
-- compile means pulp browserify > and then open something
  -- would be nice to have some sort of project thing I can think about that