Use ~>

Use ~>

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

  , null
  , length

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

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

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

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

  , sort
  , sortBy

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

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

  , (\\), difference
  , intersect
  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex

  , module Exports
  ) where

import Prelude

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

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

import Partial.Unsafe (unsafePartial)

-- | Convert an `Array` into an `Unfoldable` structure.
toUnfoldable :: forall f. 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))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

infix 5 difference as \\

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

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

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

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

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

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

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

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

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

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

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

  , null
  , length

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

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

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

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

  , sort
  , sortBy

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

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

  , (\\), difference
  , intersect
  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex

  , module Exports
  ) where

import Prelude

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

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

import Partial.Unsafe (unsafePartial)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

infix 5 difference as \\

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

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

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

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

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

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

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

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

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

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


Added fixity declaration to (..) (range operator)

module Data.Array
  ( (!!)
  , (..)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , mapMaybe
  , catMaybes
  , length
  , findIndex
  , findLastIndex
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , drop
  , take
  , insertAt
  , deleteAt
  , updateAt
  , deleteBy
  , delete
  , (\\)
  , intersectBy
  , intersect
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  , sortBy
  , group
  , group'
  , groupBy
  , span
  , dropWhile
  , takeWhile
  ) where

import Control.Alt
import Control.Plus
import Control.Alternative
import Control.MonadPlus
import Data.Maybe
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

(!!) :: forall a. [a] -> Number -> Maybe a
(!!) xs n =
  if n < 0 || n >= (length xs) || isInt n
    then Nothing
    else Just (xs `unsafeIndex` n)
  where
  isInt n = n /= complement (complement n)

foreign import snoc
  "function snoc(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _       = Nothing

last :: forall a. [a] -> Maybe a
last (x : []) = Just x
last (_ : xs) = last xs
last _        = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice 0 (length xs - 1) xs)

null :: forall a. [a] -> Boolean
null [] = true
null _  = false

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import findIndex
  "function findIndex (f) {\
  \  return function (arr) {\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

foreign import findLastIndex
  "function findLastIndex (f) {\
  \  return function (arr) {\
  \    for (var i = arr.length - 1; i >= 0; i--) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

elemIndex :: forall a. (Eq a) => a -> [a] -> Number
elemIndex x = findIndex ((==) x)

elemLastIndex :: forall a. (Eq a) => a -> [a] -> Number
elemLastIndex x = findLastIndex ((==) x)

foreign import append
  "function append (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import concat
  "function concat (xss) {\
  \  var result = [];\
  \  for (var i = 0, l = xss.length; i < l; i++) {\
  \    result.push.apply(result, xss[i]);\
  \  }\
  \  return result;\
  \}" :: forall a. [[a]] -> [a]

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

take :: forall a. Number -> [a] -> [a]
take n = slice 0 n

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var i = ~~index;\
  \      if (i < 0 || i >= l.length) return l;\
  \      var l1 = l.slice();\
  \      l1[i] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

deleteBy :: forall a. (a -> a -> Boolean) -> a -> [a] -> [a]
deleteBy _ _ [] = []
deleteBy eq x ys = case findIndex (eq x) ys of
  i | i < 0 -> ys
  i -> deleteAt i 1 ys

delete :: forall a. (Eq a) => a -> [a] -> [a]
delete = deleteBy (==)

infix 5 \\

(\\) :: forall a. (Eq a) => [a] -> [a] -> [a]
(\\) xs ys = go xs ys
  where
  go xs [] = xs
  go [] _  = []
  go xs (y:ys) = go (delete y xs) ys

intersectBy :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> [a]
intersectBy _  [] _  = []
intersectBy _  _  [] = []
intersectBy eq xs ys = filter el xs
  where
  el x = findIndex (eq x) ys >= 0

intersect :: forall a. (Eq a) => [a] -> [a] -> [a]
intersect = intersectBy (==)

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

mapMaybe :: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f = concatMap (maybe [] singleton <<< f)

catMaybes :: forall a. [Maybe a] -> [a]
catMaybes = concatMap (maybe [] singleton)

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

foreign import range
  "function range (start) {\
  \  return function (end) {\
  \    var i = ~~start, e = ~~end;\
  \    var step = i > e ? -1 : 1;\
  \    var result = [i], n = 1;\
  \    while (i !== e) {\
  \      i += step;\
  \      result[n++] = i;\
  \    }\
  \    return result;\
  \  };\
  \}" :: Number -> Number -> [Number]

infix 8 ..
(..) :: Number -> Number -> [Number]
(..) = range

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortBy compare xs

sortBy :: forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy comp xs = sortJS comp' xs
  where
    comp' x y = case comp x y of
      GT -> 1
      EQ -> 0
      LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

group :: forall a. (Eq a) => [a] -> [[a]]
group xs = groupBy (==) xs

-- | Performs a sorting first.
group' :: forall a. (Ord a) => [a] -> [[a]]
group' = group <<< sort

groupBy :: forall a. (a -> a -> Boolean) -> [a] -> [[a]]
groupBy = go []
  where
  go :: forall a. [[a]] -> (a -> a -> Boolean) -> [a] -> [[a]]
  go acc _  []     = reverse acc
  go acc op (x:xs) = let sp = span (op x) xs in
                     go ((x:sp.init):acc) op sp.rest

span :: forall a. (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
span = go []
  where
  go :: forall a. [a] -> (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
  go acc p (x:xs) | p x = go (x:acc) p xs
  go acc _ xs           = { init: reverse acc, rest: xs }

takeWhile :: forall a. (a -> Boolean) -> [a] -> [a]
takeWhile p xs = (span p xs).init

dropWhile :: forall a. (a -> Boolean) -> [a] -> [a]
dropWhile p xs = (span p xs).rest

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance altArray :: Alt [] where
  (<|>) = append

instance plusArray :: Plus [] where
  empty = []

instance alternativeArray :: Alternative []

instance monadPlusArray :: MonadPlus []

module Data.Array
  ( (!!)
  , (..)
  , snoc
  , singleton
  , head
  , last
  , tail
  , init
  , null
  , map
  , mapMaybe
  , catMaybes
  , length
  , findIndex
  , findLastIndex
  , elemIndex
  , elemLastIndex
  , append
  , concat
  , reverse
  , drop
  , take
  , insertAt
  , deleteAt
  , updateAt
  , deleteBy
  , delete
  , (\\)
  , intersectBy
  , intersect
  , concatMap
  , filter
  , range
  , zipWith
  , nub
  , nubBy
  , sort
  , sortBy
  , group
  , group'
  , groupBy
  , span
  , dropWhile
  , takeWhile
  ) where

import Control.Alt
import Control.Plus
import Control.Alternative
import Control.MonadPlus
import Data.Maybe
import Prelude.Unsafe (unsafeIndex)

infixl 8 !!

(!!) :: forall a. [a] -> Number -> Maybe a
(!!) xs n =
  if n < 0 || n >= (length xs) || isInt n
    then Nothing
    else Just (xs `unsafeIndex` n)
  where
  isInt n = n /= complement (complement n)

foreign import snoc
  "function snoc(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

singleton :: forall a. a -> [a]
singleton a = [a]

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _       = Nothing

last :: forall a. [a] -> Maybe a
last (x : []) = Just x
last (_ : xs) = last xs
last _        = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _        = Nothing

init :: forall a. [a] -> Maybe [a]
init [] = Nothing
init xs = Just (slice 0 (length xs - 1) xs)

null :: forall a. [a] -> Boolean
null [] = true
null _  = false

foreign import length
  "function length (xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import findIndex
  "function findIndex (f) {\
  \  return function (arr) {\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

foreign import findLastIndex
  "function findLastIndex (f) {\
  \  return function (arr) {\
  \    for (var i = arr.length - 1; i >= 0; i--) {\
  \      if (f(arr[i])) {\
  \        return i;\
  \      }\
  \    }\
  \    return -1;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> Number

elemIndex :: forall a. (Eq a) => a -> [a] -> Number
elemIndex x = findIndex ((==) x)

elemLastIndex :: forall a. (Eq a) => a -> [a] -> Number
elemLastIndex x = findLastIndex ((==) x)

foreign import append
  "function append (l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import concat
  "function concat (xss) {\
  \  var result = [];\
  \  for (var i = 0, l = xss.length; i < l; i++) {\
  \    result.push.apply(result, xss[i]);\
  \  }\
  \  return result;\
  \}" :: forall a. [[a]] -> [a]

foreign import reverse
  "function reverse (l) {\
  \  return l.slice().reverse();\
  \}" :: forall a. [a] -> [a]

foreign import drop
  "function drop (n) {\
  \  return function (l) {\
  \    return l.slice(n);\
  \  };\
  \}" :: forall a. Number -> [a] -> [a]

take :: forall a. Number -> [a] -> [a]
take n = slice 0 n

foreign import slice
  "function slice (s) {\
  \  return function (e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import insertAt
  "function insertAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt (index) {\
  \  return function (n) {\
  \    return function (l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt (index) {\
  \  return function (a) {\
  \    return function (l) {\
  \      var i = ~~index;\
  \      if (i < 0 || i >= l.length) return l;\
  \      var l1 = l.slice();\
  \      l1[i] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

deleteBy :: forall a. (a -> a -> Boolean) -> a -> [a] -> [a]
deleteBy _ _ [] = []
deleteBy eq x ys = case findIndex (eq x) ys of
  i | i < 0 -> ys
  i -> deleteAt i 1 ys

delete :: forall a. (Eq a) => a -> [a] -> [a]
delete = deleteBy (==)

infix 5 \\

(\\) :: forall a. (Eq a) => [a] -> [a] -> [a]
(\\) xs ys = go xs ys
  where
  go xs [] = xs
  go [] _  = []
  go xs (y:ys) = go (delete y xs) ys

intersectBy :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> [a]
intersectBy _  [] _  = []
intersectBy _  _  [] = []
intersectBy eq xs ys = filter el xs
  where
  el x = findIndex (eq x) ys >= 0

intersect :: forall a. (Eq a) => [a] -> [a] -> [a]
intersect = intersectBy (==)

foreign import concatMap
  "function concatMap (f) {\
  \  return function (arr) {\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      Array.prototype.push.apply(result, f(arr[i]));\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> [b]) -> [a] -> [b]

foreign import map
  "function map (f) {\
  \  return function (arr) {\
  \    var l = arr.length;\
  \    var result = new Array(l);\
  \    for (var i = 0; i < l; i++) {\
  \      result[i] = f(arr[i]);\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a b. (a -> b) -> [a] -> [b]

mapMaybe :: forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f = concatMap (maybe [] singleton <<< f)

catMaybes :: forall a. [Maybe a] -> [a]
catMaybes = concatMap (maybe [] singleton)

foreign import filter
  "function filter (f) {\
  \  return function (arr) {\
  \    var n = 0;\
  \    var result = [];\
  \    for (var i = 0, l = arr.length; i < l; i++) {\
  \      if (f(arr[i])) {\
  \        result[n++] = arr[i];\
  \      }\
  \    }\
  \    return result;\
  \  };\
  \}" :: forall a. (a -> Boolean) -> [a] -> [a]

foreign import range
  "function range (start) {\
  \  return function (end) {\
  \    var i = ~~start, e = ~~end;\
  \    var step = i > e ? -1 : 1;\
  \    var result = [i], n = 1;\
  \    while (i !== e) {\
  \      i += step;\
  \      result[n++] = i;\
  \    }\
  \    return result;\
  \  };\
  \}" :: Number -> Number -> [Number]

(..) :: Number -> Number -> [Number]
(..) = range

foreign import zipWith
  "function zipWith (f) {\
  \  return function (xs) {\
  \    return function (ys) {\
  \      var l = xs.length < ys.length ? xs.length : ys.length;\
  \      var result = new Array(l);\
  \      for (var i = 0; i < l; i++) {\
  \        result[i] = f(xs[i])(ys[i]);\
  \      }\
  \      return result;\
  \    };\
  \  };\
  \}" :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

sort :: forall a. (Ord a) => [a] -> [a]
sort xs = sortBy compare xs

sortBy :: forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy comp xs = sortJS comp' xs
  where
    comp' x y = case comp x y of
      GT -> 1
      EQ -> 0
      LT -> -1

foreign import sortJS
  "function sortJS (f) {\
  \  return function (l) {\
  \    return l.slice().sort(function (x, y) {\
  \      return f(x)(y);\
  \    });\
  \  };\
  \}" :: forall a. (a -> a -> Number) -> [a] -> [a]

group :: forall a. (Eq a) => [a] -> [[a]]
group xs = groupBy (==) xs

-- | Performs a sorting first.
group' :: forall a. (Ord a) => [a] -> [[a]]
group' = group <<< sort

groupBy :: forall a. (a -> a -> Boolean) -> [a] -> [[a]]
groupBy = go []
  where
  go :: forall a. [[a]] -> (a -> a -> Boolean) -> [a] -> [[a]]
  go acc _  []     = reverse acc
  go acc op (x:xs) = let sp = span (op x) xs in
                     go ((x:sp.init):acc) op sp.rest

span :: forall a. (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
span = go []
  where
  go :: forall a. [a] -> (a -> Boolean) -> [a] -> { init :: [a], rest :: [a] }
  go acc p (x:xs) | p x = go (x:acc) p xs
  go acc _ xs           = { init: reverse acc, rest: xs }

takeWhile :: forall a. (a -> Boolean) -> [a] -> [a]
takeWhile p xs = (span p xs).init

dropWhile :: forall a. (a -> Boolean) -> [a] -> [a]
dropWhile p xs = (span p xs).rest

instance functorArray :: Functor [] where
  (<$>) = map

instance applyArray :: Apply [] where
  (<*>) = ap

instance applicativeArray :: Applicative [] where
  pure = singleton

instance bindArray :: Bind [] where
  (>>=) = flip concatMap

instance monadArray :: Monad []

instance semigroupArray :: Semigroup [a] where
  (<>) = append

instance altArray :: Alt [] where
  (<|>) = append

instance plusArray :: Plus [] where
  empty = []

instance alternativeArray :: Alternative []

instance monadPlusArray :: MonadPlus []


Read array values by recursively reading values

-- |
-- | Docopt FFI surface.
-- |
-- | Entrypoints to be called from JS-land.
-- | Data input and output is santized for either language and functions are
-- | curried/uncurried as needed.
-- |

module Docopt.FFI (
  run
, runFromSpec
, parse
, undefined
, readAsString
, readSpec
, specToForeign
) where

import Prelude
import Debug.Trace
import Data.Function.Uncurried
import Data.Bifunctor (lmap)
import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust)
import Data.List (toUnfoldable, List(Nil), fromFoldable)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Data.Tuple (Tuple())
import Data.Tuple.Nested ((/\))
import Data.Array (singleton) as Array
import Data.Traversable (traverse, for)
import Control.Monad.Eff (Eff())
import Data.Either (Either(..), either)
import Data.StrMap (StrMap())
import Control.Bind ((=<<))
import Control.Alt (alt, (<|>))
import Data.String (toChar) as String
import Data.Foreign (readBoolean, readChar, readArray, readString, typeOf, toForeign,
                    readInt, readNumber, unsafeReadTagged) as F
import Data.Foreign (Foreign, F, ForeignError(..), typeOf, unsafeFromForeign,
                    toForeign)
import Data.Foreign.Class (readProp) as F
import Data.Foreign.NullOrUndefined as F
import Language.Docopt.Argument (Branch(), Argument(..), OptionArgumentObj)
import Unsafe.Coerce (unsafeCoerce)

import Docopt as Docopt
import Language.Docopt (Specification(), Docopt())
import Language.Docopt.Value (Value(..))

type RawValue = Unit

-- | Convert a Value into a JS-native value.
rawValue :: Value -> RawValue
rawValue (BoolValue   b) = unsafeCoerce b
rawValue (IntValue    i) = unsafeCoerce i
rawValue (FloatValue  x) = unsafeCoerce x
rawValue (StringValue s) = unsafeCoerce s
rawValue (ArrayValue xs) = unsafeCoerce $ rawValue <$> xs

foreign import isTruthy :: Foreign -> Boolean

-- |
-- | Run neodoc from JS.
-- |
run :: forall e.
  Fn2 String  -- ^ The neodoc text
      Foreign -- ^ The options (optional)
      (Eff (Docopt.DocoptEff e) (StrMap RawValue))
run = mkFn2 go
  where
    go helpText rOpts = do
      result <- Docopt.run (Right helpText) (readCommonOpts rOpts)
      pure $ rawValue <$> result

-- |
-- | Run neodoc from JS, provided a spec.
-- |
runFromSpec :: forall e.
  Fn2 Foreign -- ^ The neodoc spec
      Foreign -- ^ The options (optional)
      (Eff (Docopt.DocoptEff e) (StrMap RawValue))
runFromSpec = mkFn2 go
  where
    go rSpec rOpts = do
      case (readSpec rSpec) of
        Left e -> throwException (error (show e))
        Right spec -> do
          result <- Docopt.run (Left spec) (readCommonOpts rOpts)
          pure $ rawValue <$> result

-- | Interpret a foreign value as a JS dictionary
readObject :: Foreign -> F (StrMap Foreign)
readObject value | isObject value = pure $ unsafeFromForeign value
readObject value = Left (TypeMismatch "object" (typeOf value))

-- | Is this Foreign value an object?
isObject :: Foreign -> Boolean
isObject f = F.typeOf f == "object"

-- | Read common neodoc options
readCommonOpts :: Foreign -> Docopt.Options {}
readCommonOpts o = Docopt.defaultOptions {
    -- override argv with a custom array. Defaults to using `process.argv`
    argv = flip alt Docopt.defaultOptions.argv do
            toMaybe do
              F.readProp "argv" o

    -- override the environment with a custom hashmap. Defaults to using
    -- `process.env`
  , env = flip alt Docopt.defaultOptions.env do
            toMaybe do
              unsafeCoerce <$> do
                readObject =<< F.readProp "env" o

    -- enable "options-first" parsing. Options are only parsed and
    -- validated until the first operand (positional or command) is met.
    -- Trailing options are collected into a designated placeholder.
  , optionsFirst = either (const Docopt.defaultOptions.optionsFirst) id
                    (isTruthy <$> do
                      F.readProp "optionsFirst" o)

    -- enable "smart-options" parsing. This causes singleton groups that
    -- "look like" they are describing an option to expand to such an
    -- option, e.g.: '[-o ARG]' becomes '[-o=ARG]'.
  , smartOptions = either (const Docopt.defaultOptions.smartOptions) id
                    (isTruthy <$> do
                      F.readProp "smartOptions" o)

    -- stop parsing at these custom EOA markers. This allows any option
    -- to terminate a parse and collect all subsequent args.
  , stopAt = fromMaybe Docopt.defaultOptions.stopAt do
      toMaybe do
        p <- F.readProp "stopAt" o
        unsafeCoerce (F.readArray p) <|> do
          Array.singleton <$> F.readString p

    -- don't exit the process upon failure. By default, neodoc will
    -- exit the program if an error occured, right after printing the
    -- help text alongside an error message.
  , dontExit = either (const Docopt.defaultOptions.dontExit) id
                        (isTruthy <$> do
                          F.readProp "dontExit" o)
  }

-- |
-- | Parse the help-text and return the spec as a JS value
-- |
parse :: forall e.
        Fn2 String  -- ^ The neodoc help-text
            Foreign -- ^ The options (optional)
            (Eff (Docopt.DocoptEff e) ({
              specification :: Array (Array (Array Foreign))
            , shortHelp     :: String
            }))
parse = mkFn2 go
  where
    go helpText fOpts = do
      let
        opts
          = Docopt.defaultOptions {
              -- enable "smart-options" parsing. This causes singleton groups
              -- that "look like" they are describing an option to expand to
              -- such an option, e.g.: '[-o ARG]' becomes '[-o=ARG]'.
              smartOptions
                = either (const Docopt.defaultOptions.smartOptions) id
                         (isTruthy <$> do
                           F.readProp "smartOptions" fOpts)
            }

      docopt <- Docopt.parse helpText opts
      pure $ specToForeign docopt

specToForeign
  :: Docopt
  -> { specification :: Array (Array (Array Foreign))
     , shortHelp     :: String
     }
specToForeign { shortHelp, specification } =
    let
      jsSpecification = toUnfoldable do
        specification <#> \branches -> do
          toUnfoldable do
            convBranch <$> branches

    in {
      shortHelp:     shortHelp
    , specification: jsSpecification
    }

    where
    convBranch :: Branch -> Array Foreign
    convBranch args = toUnfoldable $ convArg <$> args

    convArg :: Argument -> Foreign
    convArg (EOA)          = F.toForeign { type: "EOA" }
    convArg (Stdin)        = F.toForeign { type: "Stdin" }
    convArg (Command x)    = F.toForeign { type: "Command", value: x }
    convArg (Positional x) = F.toForeign { type: "Positional", value: x }
    convArg (Group x)      = F.toForeign {
      type: "Group"
    , value: {
        optional:   x.optional
      , repeatable: x.repeatable
      , branches:   (toUnfoldable $ convBranch <$> x.branches) :: Array (Array Foreign)
      }
    }
    convArg (Option x) = F.toForeign {
      type: "Option"
    , value: {
        flag:       maybe undefined F.toForeign x.flag
      , name:       maybe undefined F.toForeign x.name
      , env:        maybe undefined F.toForeign x.env
      , repeatable: x.repeatable
      , arg:        maybe undefined (\a -> {
                      name:     a.name
                    , default:  maybe undefined rawValue a.default
                    , optional: a.optional
                    }) x.arg
      }
    }

-- |
-- | Parse a foreign value into a specification
-- |
readSpec :: Foreign -> F Docopt
readSpec input = do
  shortHelp  <- F.readProp "shortHelp" input
  jsSpec     <- F.readProp "specification" input
  toplevel   <- F.readArray jsSpec
  spec       <- fromFoldable <$> do
    for toplevel \usage -> do
      branches <- F.readArray usage
      fromFoldable <$> do
        for branches \branch -> do
          args <- F.readArray branch
          fromFoldable <$> do
            for args readArg
  pure {
    shortHelp:     shortHelp
  , specification: spec
  }

  where
  readNode :: Foreign -> F (Tuple String (Maybe Foreign))
  readNode o = (/\) <$> (F.readString =<< F.readProp "type" o)
                    <*> ((Just <$> F.readProp "value" o) <|> pure Nothing)

  readArg :: Foreign -> F (Argument)
  readArg o = do
    n <- readNode o
    case n of
      "Group" /\ (Just v) -> do
        grp <$> (isTruthy <$> F.readProp "optional" v)
            <*> (isTruthy <$> F.readProp "repeatable" v)
            <*> (fromFoldable <$> do
                  branches <- F.readArray =<< F.readProp "branches" v
                  for branches \branch -> do
                    args <- F.readArray branch
                    fromFoldable <$> do
                      for args readArg
                )
      "Command" /\ (Just v) -> do
        co <$> (readAsString =<< F.readProp "name" v)
           <*> (isTruthy <$> F.readProp "repeatable" v)
      "Positional" /\ (Just v) -> do
        po <$> (readAsString =<< F.readProp "name" v)
           <*> (isTruthy <$> F.readProp "repeatable" v)
      "Option" /\ (Just v) -> do
        opt <$> (ifHasProp v "flag" readFlag)
            <*> (ifHasProp v "name" readAsString)
            <*> (isTruthy <$> F.readProp "repeatable" v)
            <*> (ifHasProp v "env" readAsString)
            <*> (readOptArg v)
      "Stdin" /\ _ -> pure Stdin
      "EOA"   /\ _ -> pure EOA
      x /\ _ -> Left (TypeMismatch "Group, Command, Positional, Option, Stdin or EOA" x)

  readOptArg :: Foreign -> F (Maybe OptionArgumentObj)
  readOptArg v = "option-argument" <?> do
    mx <- nullOrUndefined (F.readProp "arg" v)
    case mx of
      Nothing -> pure Nothing
      Just x  -> Just <$> do
          arg <$> (ifHasProp' x "name" "<ARG>" readAsString)
              <*> (ifHasProp  x "default" readValue)
              <*> (isTruthy <$> F.readProp "optional" x)

  readFlag :: Foreign -> F Char
  readFlag v = "flag. Must be a single character." <?> do
      s <- readAsString v
      F.readChar (F.toForeign s)

  grp x y z     = Group      { optional: x, repeatable: y, branches: z }
  co  x y       = Command    { name: x, repeatable: y }
  po  x y       = Positional { name: x, repeatable: y }
  opt a b c d e = Option     { flag: a, name: b, repeatable: c, env: d, arg: e }
  arg x y z     = { name: x, default: y, optional: z }

readValue :: Foreign -> F Value
readValue x =
  (BoolValue   <$> F.readBoolean x) <|>
  (IntValue    <$> F.readInt     x) <|>
  (FloatValue  <$> F.readNumber  x) <|>
  (StringValue <$> F.readString  x) <|>
  (ArrayValue  <$> (F.readArray x >>= \vs -> for vs readValue))

optional :: forall a. F a -> F (Maybe a)
optional x = (Just <$> x) <|> pure Nothing

ifHasProp :: forall a. Foreign -> String -> (Foreign -> F a) -> F (Maybe a)
ifHasProp v s f = do
  mv <- nullOrUndefined (F.readProp s v)
  case mv of
    Nothing -> pure Nothing
    Just  v -> Just <$> f v

ifHasProp' :: forall a. Foreign -> String -> a -> (Foreign -> F a) -> F a
ifHasProp' v s o f = do
  mv <- ifHasProp v s f
  pure (fromMaybe o mv)

toMaybe :: forall a b. Either a b -> Maybe b
toMaybe e = either (const Nothing) (pure <<< id) e

readAsString :: Foreign -> F String
readAsString v = do
  (             (F.unsafeReadTagged "String"  v :: F String)) <|>
  (toString <$> (F.unsafeReadTagged "Boolean" v :: F String)) <|>
  (toString <$> (F.unsafeReadTagged "Number"  v :: F String))

nullOrUndefined :: F Foreign -> F (Maybe Foreign)
nullOrUndefined x = F.unNullOrUndefined <$> do
  F.readNullOrUndefined pure =<< x

infixl 9 expected as <?>
expected :: forall a. String -> F a -> F a
expected msg x = lmap (\_ -> JSONError $ "Invalid " <> msg) x

foreign import undefined :: forall a. a
foreign import toString  :: forall a. a -> String

-- |
-- | Docopt FFI surface.
-- |
-- | Entrypoints to be called from JS-land.
-- | Data input and output is santized for either language and functions are
-- | curried/uncurried as needed.
-- |

module Docopt.FFI (
  run
, runFromSpec
, parse
, undefined
, readAsString
, readSpec
, specToForeign
) where

import Prelude
import Debug.Trace
import Data.Function.Uncurried
import Data.Bifunctor (lmap)
import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust)
import Data.List (toUnfoldable, List(Nil), fromFoldable)
import Control.Monad.Eff.Exception (error, throwException, EXCEPTION())
import Data.Tuple (Tuple())
import Data.Tuple.Nested ((/\))
import Data.Array (singleton) as Array
import Data.Traversable (traverse, for)
import Control.Monad.Eff (Eff())
import Data.Either (Either(..), either)
import Data.StrMap (StrMap())
import Control.Bind ((=<<))
import Control.Alt (alt, (<|>))
import Data.String (toChar) as String
import Data.Foreign (readBoolean, readChar, readArray, readString, typeOf, toForeign,
                    readInt, readNumber, unsafeReadTagged) as F
import Data.Foreign (Foreign, F, ForeignError(..), typeOf, unsafeFromForeign,
                    toForeign)
import Data.Foreign.Class (readProp) as F
import Data.Foreign.NullOrUndefined as F
import Language.Docopt.Argument (Branch(), Argument(..), OptionArgumentObj)
import Unsafe.Coerce (unsafeCoerce)

import Docopt as Docopt
import Language.Docopt (Specification(), Docopt())
import Language.Docopt.Value (Value(..))

type RawValue = Unit

-- | Convert a Value into a JS-native value.
rawValue :: Value -> RawValue
rawValue (BoolValue   b) = unsafeCoerce b
rawValue (IntValue    i) = unsafeCoerce i
rawValue (FloatValue  x) = unsafeCoerce x
rawValue (StringValue s) = unsafeCoerce s
rawValue (ArrayValue xs) = unsafeCoerce $ rawValue <$> xs

foreign import isTruthy :: Foreign -> Boolean

-- |
-- | Run neodoc from JS.
-- |
run :: forall e.
  Fn2 String  -- ^ The neodoc text
      Foreign -- ^ The options (optional)
      (Eff (Docopt.DocoptEff e) (StrMap RawValue))
run = mkFn2 go
  where
    go helpText rOpts = do
      result <- Docopt.run (Right helpText) (readCommonOpts rOpts)
      pure $ rawValue <$> result

-- |
-- | Run neodoc from JS, provided a spec.
-- |
runFromSpec :: forall e.
  Fn2 Foreign -- ^ The neodoc spec
      Foreign -- ^ The options (optional)
      (Eff (Docopt.DocoptEff e) (StrMap RawValue))
runFromSpec = mkFn2 go
  where
    go rSpec rOpts = do
      case (readSpec rSpec) of
        Left e -> throwException (error (show e))
        Right spec -> do
          result <- Docopt.run (Left spec) (readCommonOpts rOpts)
          pure $ rawValue <$> result

-- | Interpret a foreign value as a JS dictionary
readObject :: Foreign -> F (StrMap Foreign)
readObject value | isObject value = pure $ unsafeFromForeign value
readObject value = Left (TypeMismatch "object" (typeOf value))

-- | Is this Foreign value an object?
isObject :: Foreign -> Boolean
isObject f = F.typeOf f == "object"

-- | Read common neodoc options
readCommonOpts :: Foreign -> Docopt.Options {}
readCommonOpts o = Docopt.defaultOptions {
    -- override argv with a custom array. Defaults to using `process.argv`
    argv = flip alt Docopt.defaultOptions.argv do
            toMaybe do
              F.readProp "argv" o

    -- override the environment with a custom hashmap. Defaults to using
    -- `process.env`
  , env = flip alt Docopt.defaultOptions.env do
            toMaybe do
              unsafeCoerce <$> do
                readObject =<< F.readProp "env" o

    -- enable "options-first" parsing. Options are only parsed and
    -- validated until the first operand (positional or command) is met.
    -- Trailing options are collected into a designated placeholder.
  , optionsFirst = either (const Docopt.defaultOptions.optionsFirst) id
                    (isTruthy <$> do
                      F.readProp "optionsFirst" o)

    -- enable "smart-options" parsing. This causes singleton groups that
    -- "look like" they are describing an option to expand to such an
    -- option, e.g.: '[-o ARG]' becomes '[-o=ARG]'.
  , smartOptions = either (const Docopt.defaultOptions.smartOptions) id
                    (isTruthy <$> do
                      F.readProp "smartOptions" o)

    -- stop parsing at these custom EOA markers. This allows any option
    -- to terminate a parse and collect all subsequent args.
  , stopAt = fromMaybe Docopt.defaultOptions.stopAt do
      toMaybe do
        p <- F.readProp "stopAt" o
        unsafeCoerce (F.readArray p) <|> do
          Array.singleton <$> F.readString p

    -- don't exit the process upon failure. By default, neodoc will
    -- exit the program if an error occured, right after printing the
    -- help text alongside an error message.
  , dontExit = either (const Docopt.defaultOptions.dontExit) id
                        (isTruthy <$> do
                          F.readProp "dontExit" o)
  }

-- |
-- | Parse the help-text and return the spec as a JS value
-- |
parse :: forall e.
        Fn2 String  -- ^ The neodoc help-text
            Foreign -- ^ The options (optional)
            (Eff (Docopt.DocoptEff e) ({
              specification :: Array (Array (Array Foreign))
            , shortHelp     :: String
            }))
parse = mkFn2 go
  where
    go helpText fOpts = do
      let
        opts
          = Docopt.defaultOptions {
              -- enable "smart-options" parsing. This causes singleton groups
              -- that "look like" they are describing an option to expand to
              -- such an option, e.g.: '[-o ARG]' becomes '[-o=ARG]'.
              smartOptions
                = either (const Docopt.defaultOptions.smartOptions) id
                         (isTruthy <$> do
                           F.readProp "smartOptions" fOpts)
            }

      docopt <- Docopt.parse helpText opts
      pure $ specToForeign docopt

specToForeign
  :: Docopt
  -> { specification :: Array (Array (Array Foreign))
     , shortHelp     :: String
     }
specToForeign { shortHelp, specification } =
    let
      jsSpecification = toUnfoldable do
        specification <#> \branches -> do
          toUnfoldable do
            convBranch <$> branches

    in {
      shortHelp:     shortHelp
    , specification: jsSpecification
    }

    where
    convBranch :: Branch -> Array Foreign
    convBranch args = toUnfoldable $ convArg <$> args

    convArg :: Argument -> Foreign
    convArg (EOA)          = F.toForeign { type: "EOA" }
    convArg (Stdin)        = F.toForeign { type: "Stdin" }
    convArg (Command x)    = F.toForeign { type: "Command", value: x }
    convArg (Positional x) = F.toForeign { type: "Positional", value: x }
    convArg (Group x)      = F.toForeign {
      type: "Group"
    , value: {
        optional:   x.optional
      , repeatable: x.repeatable
      , branches:   (toUnfoldable $ convBranch <$> x.branches) :: Array (Array Foreign)
      }
    }
    convArg (Option x) = F.toForeign {
      type: "Option"
    , value: {
        flag:       maybe undefined F.toForeign x.flag
      , name:       maybe undefined F.toForeign x.name
      , env:        maybe undefined F.toForeign x.env
      , repeatable: x.repeatable
      , arg:        maybe undefined (\a -> {
                      name:     a.name
                    , default:  maybe undefined rawValue a.default
                    , optional: a.optional
                    }) x.arg
      }
    }

-- |
-- | Parse a foreign value into a specification
-- |
readSpec :: Foreign -> F Docopt
readSpec input = do
  shortHelp  <- F.readProp "shortHelp" input
  jsSpec     <- F.readProp "specification" input
  toplevel   <- F.readArray jsSpec
  spec       <- fromFoldable <$> do
    for toplevel \usage -> do
      branches <- F.readArray usage
      fromFoldable <$> do
        for branches \branch -> do
          args <- F.readArray branch
          fromFoldable <$> do
            for args readArg
  pure {
    shortHelp:     shortHelp
  , specification: spec
  }

  where
  readNode :: Foreign -> F (Tuple String (Maybe Foreign))
  readNode o = (/\) <$> (F.readString =<< F.readProp "type" o)
                    <*> ((Just <$> F.readProp "value" o) <|> pure Nothing)

  readArg :: Foreign -> F (Argument)
  readArg o = do
    n <- readNode o
    case n of
      "Group" /\ (Just v) -> do
        grp <$> (isTruthy <$> F.readProp "optional" v)
            <*> (isTruthy <$> F.readProp "repeatable" v)
            <*> (fromFoldable <$> do
                  branches <- F.readArray =<< F.readProp "branches" v
                  for branches \branch -> do
                    args <- F.readArray branch
                    fromFoldable <$> do
                      for args readArg
                )
      "Command" /\ (Just v) -> do
        co <$> (readAsString =<< F.readProp "name" v)
           <*> (isTruthy <$> F.readProp "repeatable" v)
      "Positional" /\ (Just v) -> do
        po <$> (readAsString =<< F.readProp "name" v)
           <*> (isTruthy <$> F.readProp "repeatable" v)
      "Option" /\ (Just v) -> do
        opt <$> (ifHasProp v "flag" readFlag)
            <*> (ifHasProp v "name" readAsString)
            <*> (isTruthy <$> F.readProp "repeatable" v)
            <*> (ifHasProp v "env" readAsString)
            <*> (readOptArg v)
      "Stdin" /\ _ -> pure Stdin
      "EOA"   /\ _ -> pure EOA
      x /\ _ -> Left (TypeMismatch "Group, Command, Positional, Option, Stdin or EOA" x)

  readOptArg :: Foreign -> F (Maybe OptionArgumentObj)
  readOptArg v = "option-argument" <?> do
    mx <- nullOrUndefined (F.readProp "arg" v)
    case mx of
      Nothing -> pure Nothing
      Just x  -> Just <$> do
          arg <$> (ifHasProp' x "name" "<ARG>" readAsString)
              <*> (ifHasProp  x "default" \x ->
                      (BoolValue   <$> F.readBoolean x) <|>
                      (IntValue    <$> F.readInt     x) <|>
                      (FloatValue  <$> F.readNumber  x) <|>
                      (StringValue <$> F.readString  x)
                  )
              <*> (isTruthy <$> F.readProp "optional" x)

  readFlag :: Foreign -> F Char
  readFlag v = "flag. Must be a single character." <?> do
      s <- readAsString v
      F.readChar (F.toForeign s)

  grp x y z     = Group      { optional: x, repeatable: y, branches: z }
  co  x y       = Command    { name: x, repeatable: y }
  po  x y       = Positional { name: x, repeatable: y }
  opt a b c d e = Option     { flag: a, name: b, repeatable: c, env: d, arg: e }
  arg x y z     = { name: x, default: y, optional: z }

optional :: forall a. F a -> F (Maybe a)
optional x = (Just <$> x) <|> pure Nothing

ifHasProp :: forall a. Foreign -> String -> (Foreign -> F a) -> F (Maybe a)
ifHasProp v s f = do
  mv <- nullOrUndefined (F.readProp s v)
  case mv of
    Nothing -> pure Nothing
    Just  v -> Just <$> f v

ifHasProp' :: forall a. Foreign -> String -> a -> (Foreign -> F a) -> F a
ifHasProp' v s o f = do
  mv <- ifHasProp v s f
  pure (fromMaybe o mv)

toMaybe :: forall a b. Either a b -> Maybe b
toMaybe e = either (const Nothing) (pure <<< id) e

readAsString :: Foreign -> F String
readAsString v = do
  (             (F.unsafeReadTagged "String"  v :: F String)) <|>
  (toString <$> (F.unsafeReadTagged "Boolean" v :: F String)) <|>
  (toString <$> (F.unsafeReadTagged "Number"  v :: F String))

nullOrUndefined :: F Foreign -> F (Maybe Foreign)
nullOrUndefined x = F.unNullOrUndefined <$> do
  F.readNullOrUndefined pure =<< x

infixl 9 expected as <?>
expected :: forall a. String -> F a -> F a
expected msg x = lmap (\_ -> JSONError $ "Invalid " <> msg) x

foreign import undefined :: forall a. a
foreign import toString  :: forall a. a -> String


Add show instance for ParserEror

Add show instance for ParserEror

module Neodoc.ArgParser.Type (
  ParseError (..)
, Parser (..)
, Step (..)
, Result
, IsConsumed
, unParser
, runParser
, getConfig
, getInput
, setInput
, fail
, fail'
, throw
, catch
, catch'
, extractError

-- `ArgParser`
, Input
, ArgParser
, ArgParseError (..)
, ParseConfig
, lookupDescription
, lookupDescription'
) where

import Prelude
import Data.List (List)
import Data.Either (Either(..))
import Control.Lazy (class Lazy)
import Control.MonadPlus (class MonadPlus, class MonadZero, class Alternative)
import Control.Plus (class Plus, class Alt)
import Neodoc.Spec (Spec)
import Neodoc.Data.Layout
import Neodoc.Data.SolvedLayout
import Neodoc.ArgParser.Options
import Neodoc.ArgParser.Token
import Neodoc.ArgParser.Lexer as L
import Neodoc.OptionAlias (OptionAlias)

-- `ArgParser`
import Data.Maybe (Maybe(..), fromMaybe)
import Data.List (head, filter)
import Data.Pretty (pretty, class Pretty)
import Data.Foldable (any, intercalate)
import Data.NonEmpty ((:|))
import Data.NonEmpty (singleton) as NonEmpty
import Control.Alt ((<|>))
import Neodoc.Env
import Neodoc.Data.Description (Description(..))

data ParseError e = ParseError Boolean (Either String e)

instance showParseError :: (Show e) => Show (ParseError e) where
  show (ParseError b e) = "ParseError " <> show b <> " "<> show e

type IsConsumed = Boolean
type Result e a = Either (ParseError e) a
data Step e c s a = Step IsConsumed c s (Result e a)
data Parser e c s a = Parser (c -> s -> Step e c s a)

setConsumed :: ∀ e c s a. Boolean -> Step e c s a -> Step e c s a
setConsumed b (Step _ c s a) = Step b c s a

setConsumedOr :: ∀ e c s a. Boolean -> Step e c s a -> Step e c s a
setConsumedOr b (Step b' c s a) = Step (b || b') c s a

unParser :: ∀ e c s a. Parser e c s a -> c -> s -> Step e c s a
unParser (Parser f) = f

instance applyParser :: Apply (Parser e c s) where
  apply = ap

instance applicativeParser :: Applicative (Parser e c s) where
  pure a = Parser \c s -> Step false c s (Right a)

instance functorParser :: Functor (Parser e c s) where
  map f p = Parser \c s ->
    let step = unParser p c s
     in case step of (Step b c' s' a) -> Step b c' s' (f <$> a)

instance bindParser :: Bind (Parser e c s) where
  bind p f = Parser \c s ->
    let step = unParser p c s
     in case step of
          Step b c' s' (Left  err) -> Step b c' s' (Left err)
          Step b c' s' (Right res) -> setConsumedOr b $ unParser (f res) c' s'

instance monadParser :: Monad (Parser e c s)

catch :: ∀ e c s a. Parser e c s a -> (ParseError e -> Parser e c s a) -> Parser e c s a
catch p f = Parser \c s ->
  let step = unParser p c s
   in case step of
      Step consumed _ _ (Left (e@(ParseError fatal _)))
        | not (fatal || consumed) -> unParser (f e) c s
      _ -> step

catch' :: ∀ e c s a. (ParseError e -> Parser e c s a) -> Parser e c s a -> Parser e c s a
catch' = flip catch

throw :: ∀ e c s a. ParseError e -> Parser e c s a
throw e = Parser \c s -> Step false c s (Left e)

instance altParser :: Alt (Parser e c s) where
  alt p1 p2 = catch p1 (const p2)

instance plusParser :: Plus (Parser e c s) where
  empty = fail "No alternative"

instance alternativeParser :: Alternative (Parser e c s)

instance lazyParser :: Lazy (Parser e c s a) where
  defer f = Parser \c s -> unParser (f unit) c s

getConfig :: ∀ e c s. Parser e c s c
getConfig = Parser \c s -> Step false c s (Right c)

getInput :: ∀ e c s. Parser e c s s
getInput = Parser \c s -> Step false c s (Right s)

setInput :: ∀ e c s. s -> Parser e c s Unit
setInput s = Parser \c _ -> Step false c s (Right unit)

runParser :: ∀ e c s a. c -> s -> Parser e c s a -> Either (ParseError e) a
runParser c s p =
  let step = unParser p c s
   in case step of (Step _ _ _ r) -> r

fail :: ∀ e c s a. String -> Parser e c s a
fail message = Parser \c s -> Step false c s (Left $ ParseError false (Left message))

fail' :: ∀ e c s a. e -> Parser e c s a
fail' e = Parser \c s -> Step false c s (Left $ ParseError false (Right e))

extractError :: ∀ e . (String -> e) -> ParseError e -> e
extractError f (ParseError _ (Left  s)) = f s
extractError _ (ParseError _ (Right e)) = e

type Input = List PositionedToken

data ArgParseError
  = OptionTakesNoArgumentError OptionAlias
  | OptionRequiresArgumentError OptionAlias
  | MissingArgumentsError (List SolvedLayout)
  | UnexpectedInputError (List PositionedToken)
  | MalformedInputError String
  | GenericError String
  | InternalError String

instance showArgParseError :: Show ArgParseError where
  show (OptionTakesNoArgumentError a) = "OptionTakesNoArgumentError " <> show a
  show (OptionRequiresArgumentError a) = "OptionRequiresArgumentError " <> show a
  show (MissingArgumentsError xs) = "MissingArgumentsError " <> show xs
  show (UnexpectedInputError xs) = "UnexpectedInputError " <> show xs
  show (MalformedInputError s) = "MalformedInputError " <> show s
  show (GenericError s) = "GenericError " <> show s
  show (InternalError s) = "InternalError " <> show s

instance prettyArgParseError :: Show ArgParseError where
  show (OptionTakesNoArgumentError a) = "Option takes no argument: " <> pretty a
  show (OptionRequiresArgumentError a) = "Option requires argument: " <> pretty a
  show (MissingArgumentsError xs) = "Missing arguments: " <> (intercalate ", " $ pretty <$> xs)
  show (UnexpectedInputError xs) = "Unexpected Input: " <> (intercalate " " $ show <$> xs)
  show (MalformedInputError s) = "Malformed Input: " <> show s
  show (GenericError s) = s
  show (InternalError s) = "Internal error: " <> s

type ParseConfig r = {
  env :: Env
, options :: Options r
, descriptions :: List Description
}

type ArgParser r a = Parser ArgParseError (ParseConfig r) Input a

-- XXX: This could be more efficient using a table lookup
lookupDescription :: ∀ r. OptionAlias -> ArgParser r (Maybe Description)
lookupDescription alias = do
  { descriptions } <- getConfig
  pure $ head $ filter matchesAlias descriptions

  where
  matchesAlias (OptionDescription aliases _ _ _ _) = any (_ == alias) aliases
  matchesAlias _ = false

lookupDescription' :: ∀ r. OptionAlias -> ArgParser r Description
lookupDescription' a = fromMaybe default <$> lookupDescription a
  where default = OptionDescription (NonEmpty.singleton a) false Nothing Nothing Nothing

module Neodoc.ArgParser.Type (
  ParseError (..)
, Parser (..)
, Step (..)
, Result
, IsConsumed
, unParser
, runParser
, getConfig
, getInput
, setInput
, fail
, fail'
, throw
, catch
, catch'
, extractError

-- `ArgParser`
, Input
, ArgParser
, ArgParseError (..)
, ParseConfig
, lookupDescription
, lookupDescription'
) where

import Prelude
import Data.List (List)
import Data.Either (Either(..))
import Control.Lazy (class Lazy)
import Control.MonadPlus (class MonadPlus, class MonadZero, class Alternative)
import Control.Plus (class Plus, class Alt)
import Neodoc.Spec (Spec)
import Neodoc.Data.Layout
import Neodoc.Data.SolvedLayout
import Neodoc.ArgParser.Options
import Neodoc.ArgParser.Token
import Neodoc.ArgParser.Lexer as L
import Neodoc.OptionAlias (OptionAlias)

-- `ArgParser`
import Data.Maybe (Maybe(..), fromMaybe)
import Data.List (head, filter)
import Data.Pretty (pretty, class Pretty)
import Data.Foldable (any, intercalate)
import Data.NonEmpty ((:|))
import Data.NonEmpty (singleton) as NonEmpty
import Control.Alt ((<|>))
import Neodoc.Env
import Neodoc.Data.Description (Description(..))

data ParseError e = ParseError Boolean (Either String e)

type IsConsumed = Boolean
type Result e a = Either (ParseError e) a
data Step e c s a = Step IsConsumed c s (Result e a)
data Parser e c s a = Parser (c -> s -> Step e c s a)

setConsumed :: ∀ e c s a. Boolean -> Step e c s a -> Step e c s a
setConsumed b (Step _ c s a) = Step b c s a

setConsumedOr :: ∀ e c s a. Boolean -> Step e c s a -> Step e c s a
setConsumedOr b (Step b' c s a) = Step (b || b') c s a

unParser :: ∀ e c s a. Parser e c s a -> c -> s -> Step e c s a
unParser (Parser f) = f

instance applyParser :: Apply (Parser e c s) where
  apply = ap

instance applicativeParser :: Applicative (Parser e c s) where
  pure a = Parser \c s -> Step false c s (Right a)

instance functorParser :: Functor (Parser e c s) where
  map f p = Parser \c s ->
    let step = unParser p c s
     in case step of (Step b c' s' a) -> Step b c' s' (f <$> a)

instance bindParser :: Bind (Parser e c s) where
  bind p f = Parser \c s ->
    let step = unParser p c s
     in case step of
          Step b c' s' (Left  err) -> Step b c' s' (Left err)
          Step b c' s' (Right res) -> setConsumedOr b $ unParser (f res) c' s'

instance monadParser :: Monad (Parser e c s)

catch :: ∀ e c s a. Parser e c s a -> (ParseError e -> Parser e c s a) -> Parser e c s a
catch p f = Parser \c s ->
  let step = unParser p c s
   in case step of
      Step consumed _ _ (Left (e@(ParseError fatal _)))
        | not (fatal || consumed) -> unParser (f e) c s
      _ -> step

catch' :: ∀ e c s a. (ParseError e -> Parser e c s a) -> Parser e c s a -> Parser e c s a
catch' = flip catch

throw :: ∀ e c s a. ParseError e -> Parser e c s a
throw e = Parser \c s -> Step false c s (Left e)

instance altParser :: Alt (Parser e c s) where
  alt p1 p2 = catch p1 (const p2)

instance plusParser :: Plus (Parser e c s) where
  empty = fail "No alternative"

instance alternativeParser :: Alternative (Parser e c s)

instance lazyParser :: Lazy (Parser e c s a) where
  defer f = Parser \c s -> unParser (f unit) c s

getConfig :: ∀ e c s. Parser e c s c
getConfig = Parser \c s -> Step false c s (Right c)

getInput :: ∀ e c s. Parser e c s s
getInput = Parser \c s -> Step false c s (Right s)

setInput :: ∀ e c s. s -> Parser e c s Unit
setInput s = Parser \c _ -> Step false c s (Right unit)

runParser :: ∀ e c s a. c -> s -> Parser e c s a -> Either (ParseError e) a
runParser c s p =
  let step = unParser p c s
   in case step of (Step _ _ _ r) -> r

fail :: ∀ e c s a. String -> Parser e c s a
fail message = Parser \c s -> Step false c s (Left $ ParseError false (Left message))

fail' :: ∀ e c s a. e -> Parser e c s a
fail' e = Parser \c s -> Step false c s (Left $ ParseError false (Right e))

extractError :: ∀ e . (String -> e) -> ParseError e -> e
extractError f (ParseError _ (Left  s)) = f s
extractError _ (ParseError _ (Right e)) = e

type Input = List PositionedToken

data ArgParseError
  = OptionTakesNoArgumentError OptionAlias
  | OptionRequiresArgumentError OptionAlias
  | MissingArgumentsError (List SolvedLayout)
  | UnexpectedInputError (List PositionedToken)
  | MalformedInputError String
  | GenericError String
  | InternalError String

instance showArgParseError :: Show ArgParseError where
  show (OptionTakesNoArgumentError a) = "OptionTakesNoArgumentError " <> show a
  show (OptionRequiresArgumentError a) = "OptionRequiresArgumentError " <> show a
  show (MissingArgumentsError xs) = "MissingArgumentsError " <> show xs
  show (UnexpectedInputError xs) = "UnexpectedInputError " <> show xs
  show (MalformedInputError s) = "MalformedInputError " <> show s
  show (GenericError s) = "GenericError " <> show s
  show (InternalError s) = "InternalError " <> show s

instance prettyArgParseError :: Show ArgParseError where
  show (OptionTakesNoArgumentError a) = "Option takes no argument: " <> pretty a
  show (OptionRequiresArgumentError a) = "Option requires argument: " <> pretty a
  show (MissingArgumentsError xs) = "Missing arguments: " <> (intercalate ", " $ pretty <$> xs)
  show (UnexpectedInputError xs) = "Unexpected Input: " <> (intercalate " " $ show <$> xs)
  show (MalformedInputError s) = "Malformed Input: " <> show s
  show (GenericError s) = s
  show (InternalError s) = "Internal error: " <> s

type ParseConfig r = {
  env :: Env
, options :: Options r
, descriptions :: List Description
}

type ArgParser r a = Parser ArgParseError (ParseConfig r) Input a

-- XXX: This could be more efficient using a table lookup
lookupDescription :: ∀ r. OptionAlias -> ArgParser r (Maybe Description)
lookupDescription alias = do
  { descriptions } <- getConfig
  pure $ head $ filter matchesAlias descriptions

  where
  matchesAlias (OptionDescription aliases _ _ _ _) = any (_ == alias) aliases
  matchesAlias _ = false

lookupDescription' :: ∀ r. OptionAlias -> ArgParser r Description
lookupDescription' a = fromMaybe default <$> lookupDescription a
  where default = OptionDescription (NonEmpty.singleton a) false Nothing Nothing Nothing