Fix some minor documentation errors

Fix some minor documentation errors

Typo: "Rakes" vs "Takes", and also replace "list" with "array" where
appropriate.

-- | 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
  , updateAtIndices
  , modifyAt
  , modifyAtIndices
  , 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, pokeSTArray, pushSTArray, modifySTArray, withArray)
import Data.Array.ST.Iterator (iterator, iterate, pushWhile)
import Data.Foldable (class Foldable, foldl, foldr, traverse_)
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(..), uncurry)
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

-- | Change the elements at the specified indices in index/value pairs.
-- | Out-of-bounds indices will have no effect.
updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> Array a -> Array a
updateAtIndices us xs =
  pureST (withArray (\res -> traverse_ (uncurry $ pokeSTArray res) us) xs)

-- | Apply a function to the element at the specified indices,
-- | creating a new array. Out-of-bounds indices will have no effect.
modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> Array a -> Array a
modifyAtIndices is f xs =
  pureST (withArray (\res -> traverse_ (\i -> modifySTArray res i f) is) 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)

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

-- | Transforms an array of pairs into an array of first components and an
-- | array 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
  , updateAtIndices
  , modifyAt
  , modifyAtIndices
  , 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, pokeSTArray, pushSTArray, modifySTArray, withArray)
import Data.Array.ST.Iterator (iterator, iterate, pushWhile)
import Data.Foldable (class Foldable, foldl, foldr, traverse_)
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(..), uncurry)
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

-- | Change the elements at the specified indices in index/value pairs.
-- | Out-of-bounds indices will have no effect.
updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> Array a -> Array a
updateAtIndices us xs =
  pureST (withArray (\res -> traverse_ (uncurry $ pokeSTArray res) us) xs)

-- | Apply a function to the element at the specified indices,
-- | creating a new array. Out-of-bounds indices will have no effect.
modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> Array a -> Array a
modifyAtIndices is f xs =
  pureST (withArray (\res -> traverse_ (\i -> modifySTArray res i f) is) 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


Fix comment

Fix comment

module Yesod.Auth
  ( Endpoint()
  , LoginSuccess(..)
  , LoginError(..)
  , login
  , login'
  , logout
  , logout'
  ) where

import Control.Monad.Aff (Aff())
import Data.Maybe (Maybe(Just, Nothing))
import Network.HTTP.Affjax (AJAX())
import Network.HTTP.Affjax (post, post') as Ajax
import Prelude (class Eq, class Show, Unit, (>>>), map, (<$>), (<<<))

import Data.Generic (class Generic, gShow, gEq)
import Data.Tuple (Tuple(..))
import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.String as String
import Data.Foreign.Class (readProp) as Foreign
import Network.HTTP.Affjax.Response (class Respondable, ResponseType(..))
import Network.HTTP.MimeType.Common as Mime

import Data.FormURLEncoded as FormURLEncoded

import Data.URI (printURI)
import Data.URI.Types (Authority, URIScheme, HierarchicalPart(HierarchicalPart), URI(URI))
import Data.Path.Pathy (Sandboxed, RelFile, AbsDir, file, (</>))

-- | Identifies the location of the authentication plugin.
-- | Example:
-- |
-- |     -- http://localhost:4000/auth/page/hardcoded/
-- |     myEndpoint =
-- |       { scheme: Just (URIScheme "http")
-- |       , authority:
-- |           Just (Authority
-- |                   Nothing
-- |                   [ Tuple (NameAddress "localhost" (Just 4000)) ])
-- |       , path: rootDir </> dir "auth" </> dir "page" </> dir "hardcoded"
-- |       }
type Endpoint
  = { scheme :: Maybe URIScheme
    , authority :: Maybe Authority
    , path :: AbsDir Sandboxed
    }

runEndpoint :: Endpoint -> RelFile Sandboxed -> URI
runEndpoint { scheme, authority, path } file =
  URI scheme
      (HierarchicalPart authority (Just (Left (path </> file))))
      Nothing
      Nothing

-- | Makes login query to the '/login' of the provided endpoint using given
-- | username/password. The result is returned, and the token is persisted in
-- | the session.
-- |
-- |     login myEndpoint "username" "password"
login
  :: ∀ eff.
     Endpoint
  -> String
  -> String
  -> Aff (ajax :: AJAX | eff) (Either LoginError LoginSuccess)
login endpoint = login' (printURI (runEndpoint endpoint (file "login")))

-- | This version of `login` allows to just provide URI of the '/login' endpoint
-- | as a `String`. No fancy types involved.
-- |
-- |     login' "http://localhost:7000/auth/page/hardcoded/login" "username" "password"
login'
  :: ∀ eff.
     String -- ^ URI of the login endpoint
  -> String -- ^ Username
  -> String -- ^ Password
  -> Aff (ajax :: AJAX | eff) (Either LoginError LoginSuccess)
login' uri username password =
   runLoginResponse <<< _.response <$> Ajax.post uri formquery
  where
    formquery =
      FormURLEncoded.fromArray
        [ Tuple "username" (Just username)
        , Tuple "password" (Just password) ]

-- | Makes logout query to the '/logout' of the provided endpoint using given
-- | username/password.
-- |
-- |     logout myEndpoint
logout :: ∀ eff. Endpoint -> Aff (ajax :: AJAX | eff) Unit
logout endpoint = logout' (printURI (runEndpoint endpoint (file "logout")))

-- | This version of `logout` allows to just provide URI of the '/logout' endpoint
-- | as a `String`. No fancy types involved.
-- |
-- |     logout' "http://localhost:7000/auth/page/hardcoded/logout"
logout' :: ∀ eff. String -> Aff (ajax :: AJAX | eff) Unit
logout' uri = _.response <$> Ajax.post' uri (Nothing :: Maybe Unit)

newtype LoginResponse = LoginResponse (Either LoginError LoginSuccess)

runLoginResponse :: LoginResponse -> Either LoginError LoginSuccess
runLoginResponse (LoginResponse a) = a

data LoginSuccess
  = LoginSuccess

data LoginError
  = LoginError String
  | LoginUsernameNotFound String
  | LoginInvalid

derive instance genericLoginSuccess :: Generic LoginSuccess
instance showLoginSuccess :: Show LoginSuccess where show = gShow
instance eqLoginSuccess :: Eq LoginSuccess where eq = gEq

derive instance genericLoginError :: Generic LoginError
instance showLoginError :: Show LoginError where show = gShow
instance eqLoginError :: Eq LoginError where eq = gEq

derive instance genericLoginResponse :: Generic LoginResponse
instance showLoginResponse :: Show LoginResponse where show = gShow
instance eqLoginResponse :: Eq LoginResponse where eq = gEq

instance respondableLoginResponse :: Respondable LoginResponse where
  responseType = Tuple (Just Mime.applicationJSON) JSONResponse
  fromResponse = Foreign.readProp "message" >>> map (fromMessage >>> LoginResponse)
    where
      fromMessage "Login Successful" = Right LoginSuccess
      fromMessage "Invalid username/password combination" = Left LoginInvalid
      fromMessage msg =
        case String.stripPrefix "Login not found: " msg of
          Just username -> Left (LoginUsernameNotFound username)
          Nothing -> Left (LoginError msg)

module Yesod.Auth
  ( Endpoint()
  , LoginSuccess(..)
  , LoginError(..)
  , login
  , login'
  , logout
  , logout'
  ) where

import Control.Monad.Aff (Aff())
import Data.Maybe (Maybe(Just, Nothing))
import Network.HTTP.Affjax (AJAX())
import Network.HTTP.Affjax (post, post') as Ajax
import Prelude (class Eq, class Show, Unit, (>>>), map, (<$>), (<<<))

import Data.Generic (class Generic, gShow, gEq)
import Data.Tuple (Tuple(..))
import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.String as String
import Data.Foreign.Class (readProp) as Foreign
import Network.HTTP.Affjax.Response (class Respondable, ResponseType(..))
import Network.HTTP.MimeType.Common as Mime

import Data.FormURLEncoded as FormURLEncoded

import Data.URI (printURI)
import Data.URI.Types (Authority, URIScheme, HierarchicalPart(HierarchicalPart), URI(URI))
import Data.Path.Pathy (Sandboxed, RelFile, AbsDir, file, (</>))

-- | Identifies the location of the authentication plugin.
-- | Example:
-- |
-- |     -- http://localhost:4000/auth/page/hardcoded/
-- |     myEndpoint =
-- |       { scheme: Just (URIScheme "http"
-- |       , authority:
-- |           Just (Authority
-- |                   Nothing
-- |                   [ Tuple (NameAddress "localhost" (Just 4000)) ])
-- |       , path: rootDir </> dir "auth" </> dir "page" </> dir "hardcoded"
-- |       }
type Endpoint
  = { scheme :: Maybe URIScheme
    , authority :: Maybe Authority
    , path :: AbsDir Sandboxed
    }

runEndpoint :: Endpoint -> RelFile Sandboxed -> URI
runEndpoint { scheme, authority, path } file =
  URI scheme
      (HierarchicalPart authority (Just (Left (path </> file))))
      Nothing
      Nothing

-- | Makes login query to the '/login' of the provided endpoint using given
-- | username/password. The result is returned, and the token is persisted in
-- | the session.
-- |
-- |     login myEndpoint "username" "password"
login
  :: ∀ eff.
     Endpoint
  -> String
  -> String
  -> Aff (ajax :: AJAX | eff) (Either LoginError LoginSuccess)
login endpoint = login' (printURI (runEndpoint endpoint (file "login")))

-- | This version of `login` allows to just provide URI of the '/login' endpoint
-- | as a `String`. No fancy types involved.
-- |
-- |     login' "http://localhost:7000/auth/page/hardcoded/login" "username" "password"
login'
  :: ∀ eff.
     String -- ^ URI of the login endpoint
  -> String -- ^ Username
  -> String -- ^ Password
  -> Aff (ajax :: AJAX | eff) (Either LoginError LoginSuccess)
login' uri username password =
   runLoginResponse <<< _.response <$> Ajax.post uri formquery
  where
    formquery =
      FormURLEncoded.fromArray
        [ Tuple "username" (Just username)
        , Tuple "password" (Just password) ]

-- | Makes logout query to the '/logout' of the provided endpoint using given
-- | username/password.
-- |
-- |     logout myEndpoint
logout :: ∀ eff. Endpoint -> Aff (ajax :: AJAX | eff) Unit
logout endpoint = logout' (printURI (runEndpoint endpoint (file "logout")))

-- | This version of `logout` allows to just provide URI of the '/logout' endpoint
-- | as a `String`. No fancy types involved.
-- |
-- |     logout' "http://localhost:7000/auth/page/hardcoded/logout"
logout' :: ∀ eff. String -> Aff (ajax :: AJAX | eff) Unit
logout' uri = _.response <$> Ajax.post' uri (Nothing :: Maybe Unit)

newtype LoginResponse = LoginResponse (Either LoginError LoginSuccess)

runLoginResponse :: LoginResponse -> Either LoginError LoginSuccess
runLoginResponse (LoginResponse a) = a

data LoginSuccess
  = LoginSuccess

data LoginError
  = LoginError String
  | LoginUsernameNotFound String
  | LoginInvalid

derive instance genericLoginSuccess :: Generic LoginSuccess
instance showLoginSuccess :: Show LoginSuccess where show = gShow
instance eqLoginSuccess :: Eq LoginSuccess where eq = gEq

derive instance genericLoginError :: Generic LoginError
instance showLoginError :: Show LoginError where show = gShow
instance eqLoginError :: Eq LoginError where eq = gEq

derive instance genericLoginResponse :: Generic LoginResponse
instance showLoginResponse :: Show LoginResponse where show = gShow
instance eqLoginResponse :: Eq LoginResponse where eq = gEq

instance respondableLoginResponse :: Respondable LoginResponse where
  responseType = Tuple (Just Mime.applicationJSON) JSONResponse
  fromResponse = Foreign.readProp "message" >>> map (fromMessage >>> LoginResponse)
    where
      fromMessage "Login Successful" = Right LoginSuccess
      fromMessage "Invalid username/password combination" = Left LoginInvalid
      fromMessage msg =
        case String.stripPrefix "Login not found: " msg of
          Just username -> Left (LoginUsernameNotFound username)
          Nothing -> Left (LoginError msg)


Validate program name in `UsageParserSpec`

module Test.Spec.UsageParserSpec (usageParserSpec) where

import Prelude
import Debug.Trace
import Control.Monad (when)
import Control.Monad.Aff (liftEff')
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), error, throwException)
import Control.Monad.Error.Class (throwError)
import Data.List (List(..), length, (!!), take, fromFoldable, singleton)
import Data.Either (Either(..), isRight, isLeft, either)
import Data.Maybe (Maybe(..))
import Data.Foldable (intercalate, foldMap, traverse_, for_)
import Data.Array ((..))

import Language.Docopt
import Test.Support.Usage                        as U
import Language.Docopt.SpecParser.Usage          as U
import Language.Docopt.SpecParser.Usage.Argument as U
import Language.Docopt.SpecParser.Lexer          as Lexer
import Language.Docopt.Scanner                   as Scanner
import Language.Docopt.SpecParser.Base (debug)
import Text.Wrap (dedent)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Support (vliftEff, runMaybeEff, runEitherEff, assertEqual, shouldEqual,
                    assertThrows)

data Expected a = F | P a

sopt_ f fs   r = (if r then U.soptR_ else U.sopt_) f fs
sopt  f fs a r = (if r then U.soptR else U.sopt) f fs a
lopt_ f      r = (if r then U.loptR_ else U.lopt_) f
lopt  f    a r = (if r then U.loptR else U.lopt) f a
po    n      r = (if r then U.poR else U.po) n
co    n      r = (if r then U.coR else U.co) n
arg'  n o      = { name: n, optional: o }
arg_  n        = arg' n true
arg   n        = arg' n false

usageParserSpec = \_ ->
  describe "The usage parser" do

    -- Test positionals in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "positionals" do
      runSingleArgumentTests
        [ pass "BAR"       $ po "BAR"
        , pass "<foo-qux>" $ po "<foo-qux>"
        , pass "<QUX>"     $ po "<QUX>"
        , pass "<QuX>"     $ po "<QuX>"
        , pass "<quux>"    $ po "<quux>"
        ]

    -- Commands are basically the same as positionals with some exception.
    -- Commands are those positionals that are not enclosed in <...>  and do
    -- do not only have uppercase letters.
    describe "commands" do
      runSingleArgumentTests
        [ pass "0" $ co "0" ]

    -- Test long options in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "long options" do
      runSingleArgumentTests
        [ pass "--bar"         $ lopt_ "bar"
        , fail "--bar = foo"
        , pass "--bar=<foo>"   $ lopt  "bar" (arg "foo")
        , pass "--bar=FOO"     $ lopt  "bar" (arg "FOO")
        , fail "--bar = FOO"
        , pass "--bar=fOo"     $ lopt  "bar" (arg "fOo")
        , fail "--bar = fOo"
        , fail "--bar = <foo>"
        , pass "--barFOO"      $ lopt_ "barFOO"

        , fail "--bar[ = foo]"
        , pass "--bar[=<foo>]"  $ lopt  "bar" (arg "foo")
        , pass "--bar[=FOO]"    $ lopt  "bar" (arg "FOO")
        , fail "--bar[ = FOO]"
        , pass "--bar[=fOo]"    $ lopt  "bar" (arg "fOo")
        , fail "--bar[ = fOo]"
        , fail "--bar[ = <foo>]"
        , pass "--bar[FOO]"     $ lopt  "bar" (arg "FOO")

        -- disallow space
        , fail "--bar [ = foo]"
        , fail "--bar [=<foo>]"
        , fail "--bar [=FOO]"
        , fail "--bar [ = FOO]"
        , fail "--bar [=fOo]"
        , fail "--bar [ = fOo]"
        , fail "--bar [ = <foo>]"

        , fail "--bar="
        , fail "--bar=<>"
        , fail "--bar=--foo"
        , fail "--bar=-foo"

        , fail "--bar[=]"
        , fail "--bar[=<>]"
        , fail "--bar[=--foo]"
        , fail "--bar[=-foo]"

          -- disallow immediate following by '-'
        , fail "--bar[=FOO]-"
        , fail "--BAR-"
        ]

    -- Test stacked options in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "stacked options" do
      runSingleArgumentTests
        [ pass "-b"         $ sopt_ 'b' []
        , pass "-?"         $ sopt_ '?' [] -- special chars
        , pass "-bFOO"      $ sopt_ 'b' ['F', 'O', 'O']
        , pass "-bFoo"      $ sopt_ 'b' ['F', 'o', 'o']
        , pass "-b<foo>"    $ sopt  'b' [] (arg "foo")
        , pass "-b<foo>"    $ sopt  'b' [] (arg "foo")
        , pass "-b=foo"     $ sopt  'b' [] (arg "foo")
        , pass "-b=FOO"     $ sopt  'b' [] (arg "FOO")
        , pass "-b=<foo>"   $ sopt  'b' [] (arg "foo")

        , pass "-b[FOO]"    $ sopt  'b' [] (arg "FOO")
        , pass "-b[Foo]"    $ sopt  'b' [] (arg "Foo")
        , pass "-b[<foo>]"  $ sopt  'b' [] (arg "foo")
        , pass "-b[<foo>]"  $ sopt  'b' [] (arg "foo")
        , pass "-b[=foo]"   $ sopt  'b' [] (arg "foo")
        , pass "-b[=FOO]"   $ sopt  'b' [] (arg "FOO")
        , pass "-b[=<foo>]" $ sopt  'b' [] (arg "foo")

        -- disallow space
        , fail "-b [=foo]"
        , fail "-b [=FOO]"
        , fail "-b [=<foo>]"

        , pass "-bar"       $ sopt_ 'b' ['a', 'r']
        , pass "-barFOO"    $ sopt_ 'b' ['a', 'r', 'F', 'O', 'O']
        , pass "-bar<foo>"  $ sopt  'b' ['a', 'r'] (arg "foo")
        , pass "-barFoo"    $ sopt_ 'b' ['a', 'r', 'F', 'o', 'o']
        , pass "-bar=foo"   $ sopt  'b' ['a', 'r'] (arg "foo")
        , pass "-bar=FOO"   $ sopt  'b' ['a', 'r'] (arg "FOO")
        , pass "-bar=<foo>" $ sopt  'b' ['a', 'r'] (arg "foo")
        , pass "-bAR"       $ sopt_ 'b' ['A', 'R']
        , pass "-bARfoo"    $ sopt_ 'b' ['A', 'R', 'f', 'o', 'o']

        , pass "-bar[FOO]"    $ sopt 'b' ['a', 'r'] (arg_ "FOO")
        , pass "-bar[<foo>]"  $ sopt 'b' ['a', 'r'] (arg_ "foo")
        , pass "-bar[Foo]"    $ sopt 'b' ['a', 'r'] (arg_ "Foo")
        , pass "-bar[=foo]"   $ sopt 'b' ['a', 'r'] (arg_ "foo")
        , pass "-bar[=FOO]"   $ sopt 'b' ['a', 'r'] (arg_ "FOO")
        , pass "-bar[=<foo>]" $ sopt 'b' ['a', 'r'] (arg_ "foo")
        , pass "-bAR[foo]"    $ sopt 'b' ['A', 'R'] (arg_ "foo")

          -- disallow immediate following by '-'
        , fail "-bAR[=FOO]-"
        , fail "-bAR-"
        ]

    -- Test required groups in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "required groups" do
      runSingleArgumentTests
        [ fail "()"
        , pass "(foo)"          $ U.gr [[ U.co "foo" ]]
        , pass "(foo|bar)"      $ U.gr [[ U.co "foo" ], [ U.co "bar" ]]
        , pass "(foo bar|bar)"  $ U.gr [[ U.co "foo", U.co "bar"], [ U.co "bar" ]]
        , pass "((foo)|bar)"    $ U.gr [[ U.gr [[ U.co "foo" ]] false ], [ U.co "bar" ]]
        , pass "((foo)...|bar)" $ U.gr [[ U.gr [[ U.co "foo" ]] true ], [ U.co "bar" ]]
        , fail "(()|bar)"
        , fail "(bar|())"
        , fail "(...)"
        ]

    -- Test optional groups in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "optional groups" do
      runSingleArgumentTests
        [ fail "[]"
        , pass "[foo]"          $ U.go [[ U.co "foo" ]]
        , pass "[foo|bar]"      $ U.go [[ U.co "foo" ], [U.co "bar"]]
        , pass "[foo bar|bar]"  $ U.go [[ U.co "foo", U.co "bar"], [U.co "bar"]]
        , pass "[[foo]|bar]"    $ U.go [[ U.go [[ U.co "foo" ]] false ], [U.co "bar"]]
        , pass "[[foo]...|bar]" $ U.go [[ U.go [[ U.co "foo" ]] true ], [U.co "bar"]]
        , fail "[[]|bar]"
        , fail "[bar|[]]"
        , fail "[...]"
        ]

    -- Test the EOA marker "--"
    describe "end-of-args" do
      runTests
        [ pass "--"                [[[ U.eoa ]]]
        , pass "-- FOO..."         [[[ U.eoa ]]]
        , pass "-- FOO... BAR"     [[[ U.eoa ]]]
        , pass "foo -- FOO... BAR" [[[ U.co "foo", U.eoa ]]]
        ]

    -- Test the stdin marker "-"
    describe "stdin" do
      runTests
        [ pass "-"             [[[ U.stdin ]]]
        , pass "-|-"           [[[ U.stdin ], [ U.stdin ]]]
        , pass "--foo - --bar" [[[ U.lopt_ "foo"
                                 , U.stdin
                                 , U.lopt_ "bar"
                                 ]]]
        ]

    -- Test the "[options...]", "[options]", etc. syntax
    describe "stdin" do
      runTests
        [ pass "[options...]"     [[[ U.ref ""    ]]]
        , pass "[options]"        [[[ U.ref ""    ]]]
        , pass "[foo-options]"    [[[ U.ref "foo" ]]]
        , pass "[foo-options...]" [[[ U.ref "foo" ]]]
        ]

  where

    kase :: forall a. String -> Expected a -> { i :: String, o :: Expected a }
    kase i o = { i, o }

    pass :: forall a. String -> a -> { i :: String, o :: Expected a }
    pass i o = kase i (P o)

    fail :: forall a. String -> { i :: String, o :: Expected a }
    fail i = kase i F

    runTests :: _
    runTests xs =
      for_ xs \{ i, o } -> do
        let input = "prog " <> i
        case o of
          P expectedUsages -> do
            -- deeply convert array to list
            -- (array is used for readability above)
            let
              expected'
                = ((fromFoldable <$> _)  <$> _) fromFoldable
                                         <$>    fromFoldable
                                         <$>    fromFoldable expectedUsages
            it (input
                <> " -> "
                <> intercalate "\n" (U.prettyPrintUsage <$> expected'))  do
              vliftEff do
                { program, usages } <- runEitherEff do
                  Lexer.lexUsage input >>= U.parse false
                assertEqual "prog" program
                assertEqual (U.prettyPrintUsage <$> expected')
                            (U.prettyPrintUsage <$> usages)
          otherwise -> do
            it (input <> " should fail") do
            vliftEff do
              assertThrows (const true) do
                runEitherEff do
                  toks       <- Lexer.lexUsage input
                  { usages } <- U.parse false toks
                  debug usages

    runSingleArgumentTests :: _
    runSingleArgumentTests xs =
      for_ xs \{ i, o } -> do
        for_ [ false, true ] \isRepeated -> do -- Append "..." ?
          let ys = if isRepeated then (1 .. 2) else (1 .. 1)
          for_ ys \q -> do -- "..." vs " ..." (note the space)
            let input = "prog " <> i <> (if isRepeated
                                      then (if q == 1 then "..." else " ...")
                                      else "")
            case o of
              P v -> do
                let expected = v isRepeated
                it (input <> " -> " <> U.prettyPrintArg expected)  do
                  vliftEff do
                    { program, usages } <- runEitherEff do
                      Lexer.lexUsage input >>= U.parse false
                                                    -- ^ Disable "smart-options"

                    assertEqual "prog" program
                    -- There should only be one top-level mutex group
                    (length usages) `shouldEqual` 1
                    u <- runMaybeEff $ usages !! 0
                    g <- runMaybeEff $ u !! 0
                    let result = take 1 g

                    -- Assert output matches expected
                    when (result /= (singleton expected)) do
                      throwException $ error $
                        "Unexpected output:\n"
                          <> (U.prettyPrintUsage $ singleton result)
              otherwise -> do
                it (input <> " should fail") do
                vliftEff do
                  assertThrows (const true) do
                    runEitherEff do
                      toks  <- Lexer.lexUsage input
                      { usages } <- U.parse false toks
                      debug usages

module Test.Spec.UsageParserSpec (usageParserSpec) where

import Prelude
import Debug.Trace
import Control.Monad (when)
import Control.Monad.Aff (liftEff')
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (EXCEPTION(), error, throwException)
import Control.Monad.Error.Class (throwError)
import Data.List (List(..), length, (!!), take, fromFoldable, singleton)
import Data.Either (Either(..), isRight, isLeft, either)
import Data.Maybe (Maybe(..))
import Data.Foldable (intercalate, foldMap, traverse_, for_)
import Data.Array ((..))

import Language.Docopt
import Test.Support.Usage                        as U
import Language.Docopt.SpecParser.Usage          as U
import Language.Docopt.SpecParser.Usage.Argument as U
import Language.Docopt.SpecParser.Lexer          as Lexer
import Language.Docopt.Scanner                   as Scanner
import Language.Docopt.SpecParser.Base (debug)
import Text.Wrap (dedent)

import Test.Assert (assert)
import Test.Spec (describe, it)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Support (vliftEff, runMaybeEff, runEitherEff, assertEqual, shouldEqual,
                    assertThrows)

data Expected a = F | P a

sopt_ f fs   r = (if r then U.soptR_ else U.sopt_) f fs
sopt  f fs a r = (if r then U.soptR else U.sopt) f fs a
lopt_ f      r = (if r then U.loptR_ else U.lopt_) f
lopt  f    a r = (if r then U.loptR else U.lopt) f a
po    n      r = (if r then U.poR else U.po) n
co    n      r = (if r then U.coR else U.co) n
arg'  n o      = { name: n, optional: o }
arg_  n        = arg' n true
arg   n        = arg' n false

usageParserSpec = \_ ->
  describe "The usage parser" do

    -- Test positionals in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "positionals" do
      runSingleArgumentTests
        [ pass "BAR"       $ po "BAR"
        , pass "<foo-qux>" $ po "<foo-qux>"
        , pass "<QUX>"     $ po "<QUX>"
        , pass "<QuX>"     $ po "<QuX>"
        , pass "<quux>"    $ po "<quux>"
        ]

    -- Commands are basically the same as positionals with some exception.
    -- Commands are those positionals that are not enclosed in <...>  and do
    -- do not only have uppercase letters.
    describe "commands" do
      runSingleArgumentTests
        [ pass "0" $ co "0" ]

    -- Test long options in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "long options" do
      runSingleArgumentTests
        [ pass "--bar"         $ lopt_ "bar"
        , fail "--bar = foo"
        , pass "--bar=<foo>"   $ lopt  "bar" (arg "foo")
        , pass "--bar=FOO"     $ lopt  "bar" (arg "FOO")
        , fail "--bar = FOO"
        , pass "--bar=fOo"     $ lopt  "bar" (arg "fOo")
        , fail "--bar = fOo"
        , fail "--bar = <foo>"
        , pass "--barFOO"      $ lopt_ "barFOO"

        , fail "--bar[ = foo]"
        , pass "--bar[=<foo>]"  $ lopt  "bar" (arg "foo")
        , pass "--bar[=FOO]"    $ lopt  "bar" (arg "FOO")
        , fail "--bar[ = FOO]"
        , pass "--bar[=fOo]"    $ lopt  "bar" (arg "fOo")
        , fail "--bar[ = fOo]"
        , fail "--bar[ = <foo>]"
        , pass "--bar[FOO]"     $ lopt  "bar" (arg "FOO")

        -- disallow space
        , fail "--bar [ = foo]"
        , fail "--bar [=<foo>]"
        , fail "--bar [=FOO]"
        , fail "--bar [ = FOO]"
        , fail "--bar [=fOo]"
        , fail "--bar [ = fOo]"
        , fail "--bar [ = <foo>]"

        , fail "--bar="
        , fail "--bar=<>"
        , fail "--bar=--foo"
        , fail "--bar=-foo"

        , fail "--bar[=]"
        , fail "--bar[=<>]"
        , fail "--bar[=--foo]"
        , fail "--bar[=-foo]"

          -- disallow immediate following by '-'
        , fail "--bar[=FOO]-"
        , fail "--BAR-"
        ]

    -- Test stacked options in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "stacked options" do
      runSingleArgumentTests
        [ pass "-b"         $ sopt_ 'b' []
        , pass "-?"         $ sopt_ '?' [] -- special chars
        , pass "-bFOO"      $ sopt_ 'b' ['F', 'O', 'O']
        , pass "-bFoo"      $ sopt_ 'b' ['F', 'o', 'o']
        , pass "-b<foo>"    $ sopt  'b' [] (arg "foo")
        , pass "-b<foo>"    $ sopt  'b' [] (arg "foo")
        , pass "-b=foo"     $ sopt  'b' [] (arg "foo")
        , pass "-b=FOO"     $ sopt  'b' [] (arg "FOO")
        , pass "-b=<foo>"   $ sopt  'b' [] (arg "foo")

        , pass "-b[FOO]"    $ sopt  'b' [] (arg "FOO")
        , pass "-b[Foo]"    $ sopt  'b' [] (arg "Foo")
        , pass "-b[<foo>]"  $ sopt  'b' [] (arg "foo")
        , pass "-b[<foo>]"  $ sopt  'b' [] (arg "foo")
        , pass "-b[=foo]"   $ sopt  'b' [] (arg "foo")
        , pass "-b[=FOO]"   $ sopt  'b' [] (arg "FOO")
        , pass "-b[=<foo>]" $ sopt  'b' [] (arg "foo")

        -- disallow space
        , fail "-b [=foo]"
        , fail "-b [=FOO]"
        , fail "-b [=<foo>]"

        , pass "-bar"       $ sopt_ 'b' ['a', 'r']
        , pass "-barFOO"    $ sopt_ 'b' ['a', 'r', 'F', 'O', 'O']
        , pass "-bar<foo>"  $ sopt  'b' ['a', 'r'] (arg "foo")
        , pass "-barFoo"    $ sopt_ 'b' ['a', 'r', 'F', 'o', 'o']
        , pass "-bar=foo"   $ sopt  'b' ['a', 'r'] (arg "foo")
        , pass "-bar=FOO"   $ sopt  'b' ['a', 'r'] (arg "FOO")
        , pass "-bar=<foo>" $ sopt  'b' ['a', 'r'] (arg "foo")
        , pass "-bAR"       $ sopt_ 'b' ['A', 'R']
        , pass "-bARfoo"    $ sopt_ 'b' ['A', 'R', 'f', 'o', 'o']

        , pass "-bar[FOO]"    $ sopt 'b' ['a', 'r'] (arg_ "FOO")
        , pass "-bar[<foo>]"  $ sopt 'b' ['a', 'r'] (arg_ "foo")
        , pass "-bar[Foo]"    $ sopt 'b' ['a', 'r'] (arg_ "Foo")
        , pass "-bar[=foo]"   $ sopt 'b' ['a', 'r'] (arg_ "foo")
        , pass "-bar[=FOO]"   $ sopt 'b' ['a', 'r'] (arg_ "FOO")
        , pass "-bar[=<foo>]" $ sopt 'b' ['a', 'r'] (arg_ "foo")
        , pass "-bAR[foo]"    $ sopt 'b' ['A', 'R'] (arg_ "foo")

          -- disallow immediate following by '-'
        , fail "-bAR[=FOO]-"
        , fail "-bAR-"
        ]

    -- Test required groups in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "required groups" do
      runSingleArgumentTests
        [ fail "()"
        , pass "(foo)"          $ U.gr [[ U.co "foo" ]]
        , pass "(foo|bar)"      $ U.gr [[ U.co "foo" ], [ U.co "bar" ]]
        , pass "(foo bar|bar)"  $ U.gr [[ U.co "foo", U.co "bar"], [ U.co "bar" ]]
        , pass "((foo)|bar)"    $ U.gr [[ U.gr [[ U.co "foo" ]] false ], [ U.co "bar" ]]
        , pass "((foo)...|bar)" $ U.gr [[ U.gr [[ U.co "foo" ]] true ], [ U.co "bar" ]]
        , fail "(()|bar)"
        , fail "(bar|())"
        , fail "(...)"
        ]

    -- Test optional groups in various formats.
    -- Each entry is run for both singular and repeated version.
    describe "optional groups" do
      runSingleArgumentTests
        [ fail "[]"
        , pass "[foo]"          $ U.go [[ U.co "foo" ]]
        , pass "[foo|bar]"      $ U.go [[ U.co "foo" ], [U.co "bar"]]
        , pass "[foo bar|bar]"  $ U.go [[ U.co "foo", U.co "bar"], [U.co "bar"]]
        , pass "[[foo]|bar]"    $ U.go [[ U.go [[ U.co "foo" ]] false ], [U.co "bar"]]
        , pass "[[foo]...|bar]" $ U.go [[ U.go [[ U.co "foo" ]] true ], [U.co "bar"]]
        , fail "[[]|bar]"
        , fail "[bar|[]]"
        , fail "[...]"
        ]

    -- Test the EOA marker "--"
    describe "end-of-args" do
      runTests
        [ pass "--"                $p$ [[[ U.eoa ]]]
        , pass "-- FOO..."         $p$ [[[ U.eoa ]]]
        , pass "-- FOO... BAR"     $p$ [[[ U.eoa ]]]
        , pass "foo -- FOO... BAR" $p$ [[[ U.co "foo", U.eoa ]]]
        ]

    -- Test the stdin marker "-"
    describe "stdin" do
      runTests
        [ pass "-"             $p$ [[[ U.stdin ]]]
        , pass "-|-"           $p$ [[[ U.stdin ], [ U.stdin ]]]
        , pass "--foo - --bar" $p$ [[[ U.lopt_ "foo"
                                   , U.stdin
                                   , U.lopt_ "bar"
                                   ]]]
        ]

    -- Test the "[options...]", "[options]", etc. syntax
    describe "stdin" do
      runTests
        [ pass "[options...]"     $p$ [[[ U.ref ""    ]]]
        , pass "[options]"        $p$ [[[ U.ref ""    ]]]
        , pass "[foo-options]"    $p$ [[[ U.ref "foo" ]]]
        , pass "[foo-options...]" $p$ [[[ U.ref "foo" ]]]
        ]

  where

    kase :: forall a. String -> Expected a -> { i :: String, o :: Expected a }
    kase i o = { i, o }

    pass :: forall a. String -> a -> { i :: String, o :: Expected a }
    pass i o = kase i (P o)

    p o = { expectedProgram: "prog", expectedUsages: o }

    fail :: forall a. String -> { i :: String, o :: Expected a }
    fail i = kase i F

    runTests :: _
    runTests xs =
      for_ xs \{ i, o } -> do
        let input = "foo " <> i
        case o of
          P { expectedProgram, expectedUsages } -> do
            -- deeply convert array to list
            -- (array is used for readability above)
            let
              expected'
                = ((fromFoldable <$> _)  <$> _) fromFoldable
                                         <$>    fromFoldable
                                         <$>    fromFoldable expectedUsages
            it (input
                <> " -> "
                <> intercalate "\n" (U.prettyPrintUsage <$> expected'))  do
              vliftEff do
                { usages } <- runEitherEff do
                  Lexer.lexUsage input >>= U.parse false
                flip assertEqual
                  (U.prettyPrintUsage <$> usages)
                  (U.prettyPrintUsage <$> expected')
          otherwise -> do
            it (input <> " should fail") do
            vliftEff do
              assertThrows (const true) do
                runEitherEff do
                  toks       <- Lexer.lexUsage input
                  { usages } <- U.parse false toks
                  debug usages

    runSingleArgumentTests :: _
    runSingleArgumentTests xs =
      for_ xs \{ i, o } -> do
        for_ [ false, true ] \isRepeated -> do -- Append "..." ?
          let ys = if isRepeated then (1 .. 2) else (1 .. 1)
          for_ ys \q -> do -- "..." vs " ..." (note the space)
            let input = "foo " <> i <> (if isRepeated
                                      then (if q == 1 then "..." else " ...")
                                      else "")
            case o of
              P v -> do
                let expected = v isRepeated
                it (input <> " -> " <> U.prettyPrintArg expected)  do
                  vliftEff do
                    { usages } <- runEitherEff do
                      Lexer.lexUsage input >>= U.parse false
                                                    -- ^ Disable "smart-options"

                    -- There should only be one top-level mutex group
                    (length usages) `shouldEqual` 1
                    u <- runMaybeEff $ usages !! 0
                    g <- runMaybeEff $ u !! 0
                    let result = take 1 g

                    -- Assert output matches expected
                    when (result /= (singleton expected)) do
                      throwException $ error $
                        "Unexpected output:\n"
                          <> (U.prettyPrintUsage $ singleton result)
              otherwise -> do
                it (input <> " should fail") do
                vliftEff do
                  assertThrows (const true) do
                    runEitherEff do
                      toks  <- Lexer.lexUsage input
                      { usages } <- U.parse false toks
                      debug usages


formatting

formatting

module Main where

import           Control.Monad.Eff.Class
import           Control.Monad.Eff.Console
import           Control.Monad.Eff.Random (RANDOM())
import           Data.Foreign.EasyFFI
import           Data.Maybe.Unsafe (fromJust)
import           Node.Express.App
import           Node.Express.Handler
import           Node.Express.Response
import           Prelude hiding (apply)

import           ScienceQuestions.Question
import           ScienceQuestions.Transitions

-- | The handler for the /question endpoint. Returns a random question.
questionHandler :: forall e. Transitions ->
                             Transitions ->
                             Handler (random :: RANDOM | e)
questionHandler qTransitions aTransitions = do
  -- create a random question (in the Eff context) and lift it into the
  -- Handler context
  question <- liftEff $ randomQuestion 4 (randomNextToken qTransitions)
                                         (randomNextToken aTransitions)
  sendJson question

appSetup :: forall e. Transitions ->
                      Transitions ->
                      App (random :: RANDOM, console :: CONSOLE | e)
appSetup qTransitions aTransitions = do
  liftEff $ log "Setting up"
  -- add our handler at the "/question" endpoint
  get "/question"   (questionHandler qTransitions aTransitions)

main = do
  qTransitions <- fromJust <$> loadTransitions "questions.json"
  aTransitions <- fromJust <$> loadTransitions "answers.json"
  port <- unsafeForeignFunction [""] "process.env.PORT || 8080"
  listenHttp (appSetup qTransitions aTransitions) port \_ ->
    log $ "Listening on " ++ show port