Remove filterM

Remove filterM

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

  , null
  , length

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

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

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

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

  , sort
  , sortBy

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

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


Fix property names

Fix property names

Original commit d1bdc5f0637c480d50b12e3f803bbc903d6e1498

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximum)

import Data.List as L

import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.Set as S

import Data.String as Str
import Data.String.Util as Str

import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize)

import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)
import Data.Either as Either

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = interfaceNamify $ combineNames names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "any"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "'" <> s <> "'"
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just c | isStartCharacter c -> s
                   | otherwise -> "'" <> s <> "'"

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    module_ <- getTopLevelNameGiven
    line $ """// To parse this JSON data:
//
//     import * as """ <> module_  <> """ from "./""" <> module_  <> """";
//     let value = """ <> module_  <> """.Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        for_ props \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ propertyNamify pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        if      (typ.isUnion)  return isValidUnion(typ.typs, val);
        else if (typ.isArray)  return isValidArray(typ.typ, val);
        else if (typ.isMap)    return isValidMap(typ.typ, val);
        else if (typ.isObject) return isValidObject(typ.cls, val);
        else    /*primitive*/  return isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximum)

import Data.List as L

import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.Set as S

import Data.String as Str
import Data.String.Util as Str

import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize)

import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)
import Data.Either as Either

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = interfaceNamify $ combineNames names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "any"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "\"" <> s <> "\""
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just c | isStartCharacter c -> s
                   | otherwise -> "\"" <> s <> "\""

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    module_ <- getTopLevelNameGiven
    line $ """// To parse this JSON data:
//
//     import * as """ <> module_  <> """ from "./""" <> module_  <> """";
//     let value = """ <> module_  <> """.Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.empty) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = lookupName name propertyNames
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        for_ resolved \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line "// The typeMap is used to assert that objects from"
    line "// JSON.parse conform to the types we expect them to."
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    topTypeMap <- getTopLevel >>= renderTypeMapType

    line $ """export module Convert {
    let path = [];

    export function fromJson(json: string): """ <> top <> """ {
        return cast(JSON.parse(json), """ <> topTypeMap <> """);
    }

    export function toJson(value: """ <> top <> """): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, typ: any): T {
        path = [];
        if (!isValid(typ, obj)) {
            throw `Invalid value: obj${path.join("")}`
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        if      (typ.isUnion)  return isValidUnion(typ.typs, val);
        else if (typ.isArray)  return isValidArray(typ.typ, val);
        else if (typ.isMap)    return isValidMap(typ.typ, val);
        else if (typ.isObject) return isValidObject(typ.cls, val);
        else    /*primitive*/  return isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""


Removed debug expressions

Removed debug expressions

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Quasar.Auth.Authentication
  ( authentication
  , getIdTokenFromBusSilently
  , fromEither
  , fromEitherEither
  , AuthEffects
  , EIdToken
  , AuthenticationError(..)
  , RequestIdTokenBus
  , RequestIdTokenMessage
  ) where

import Control.Coroutine as Coroutine
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as StallingCoroutine
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVAR, AffAVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus (BusRW, BusW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Aff.Promise (Promise)
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Ref (Ref, REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Rec.Class (forever)
import Control.Parallel.Class (race)
import Control.UI.Browser as Browser
import DOM (DOM)
import DOM.HTML as DOMHTML
import DOM.HTML.Document as DOMHTMLDocument
import DOM.HTML.HTMLIFrameElement as DOMHTMLIFrameElement
import DOM.HTML.Types (HTMLIFrameElement)
import DOM.HTML.Types as DOMHTMLTypes
import DOM.HTML.Window as DOMHTMLWindow
import DOM.Node.Document as DOMNodeDocument
import DOM.Node.Node as DOMNode
import DOM.Node.Types (Node, Element)
import Data.Either as E
import Data.Foldable as F
import Data.Foreign as Foreign
import Data.Maybe as M
import Data.Nullable as Nullable
import Data.Traversable as T
import OIDC.Aff as OIDCAff
import OIDC.Crypt (RSASIGNTIME)
import OIDC.Crypt as OIDCCrypt
import OIDC.Crypt.JSONWebKey (JSONWebKey)
import OIDC.Crypt.Types (IdToken(..), UnhashedNonce(..))
import Quasar.Advanced.Types (ProviderR)
import Quasar.Advanced.Types as QAT
import SlamData.Config as Config
import SlamData.Prelude
import SlamData.Quasar.Auth.IdTokenStorageEvents (getIdTokenStorageEvents)
import SlamData.Quasar.Auth.Keys as AuthKeys
import SlamData.Quasar.Auth.Store as AuthStore

import Text.Parsing.StringParser (ParseError(..))

import Utils (passover)
import Utils.LocalStorage as LocalStorage
import Utils.DOM as DOMUtils

fromEither ∷ ∀ a b. E.Either a b → M.Maybe b
fromEither = E.either (\_ → M.Nothing) (M.Just)

fromEitherEither ∷ ∀ a b c. E.Either a (E.Either b c) → M.Maybe c
fromEitherEither = E.either (\_ → M.Nothing) fromEither

getIdTokenFromBusSilently ∷ ∀ eff. RequestIdTokenBus → Aff (AuthEffects eff) (Either String EIdToken)
getIdTokenFromBusSilently requestNewIdTokenBus =
  liftEff getProviderRUsingLocalStorage
    >>= case _ of
      Right providerR → do
        idTokenVar ← AVar.makeVar
        Bus.write { idToken: idTokenVar, providerR, prompt: false } requestNewIdTokenBus
        idToken ← Right <$> AVar.takeVar idTokenVar
        pure idToken
      Left error → pure $ Left error

data AuthenticationError
  = IdTokenInvalid
  | IdTokenUnavailable String
  | PromptDismissed
  | DOMError String
  | ProviderError String

instance semigroupAuthenticationError ∷ Semigroup AuthenticationError where
  append x y = y

type RequestIdTokenMessage = { providerR ∷ ProviderR, prompt ∷ Boolean, idToken ∷ AVar EIdToken }

type RequestIdTokenBus = BusW RequestIdTokenMessage

type EIdToken = Either AuthenticationError IdToken

type AuthEffects eff =
  ( rsaSignTime ∷ RSASIGNTIME
  , avar ∷ AVAR
  , ref ∷ REF
  , dom ∷ DOM
  , random ∷ RANDOM
  | eff)

firstValueFromStallingProducer
  ∷ forall o eff
  . StallingCoroutine.StallingProducer o (Aff (avar ∷ AVAR | eff)) Unit
  → AffAVar eff o
firstValueFromStallingProducer producer = do
  firstValue ← AVar.makeVar
  Aff.forkAff
    $ StallingCoroutine.runStallingProcess
        (producer $$? (Coroutine.consumer \o → liftAff (AVar.putVar firstValue o) $> Just unit))
  val ← AVar.takeVar firstValue
  pure val

writeOnlyBus ∷ ∀ a. BusRW a → BusW a
writeOnlyBus = snd ∘ Bus.split

-- | Write an AVar to the returned bus to get a valid OIDC id token from the given provider.
authentication ∷ ∀ eff. Aff (AuthEffects eff) RequestIdTokenBus
authentication = do
  stateRef ← liftEff $ Ref.newRef Nothing
  requestBus ← Bus.make
  Aff.forkAff $ forever (authenticate stateRef =<< Bus.read requestBus)
  pure $ writeOnlyBus requestBus

-- TODO: Allow multiple concurrent auth requests with different providers
-- and prompt options. Alternatively immediately respond with an
-- "authentication already in progress" error.
--
-- Currently if a message comes in whilst authentication is in progress the
-- sender will be given the id token from the in progress auth regardless of
-- what provider they asked for.
--
-- In current use this won't happen but it could if things change.
--
-- The same thing and worse could happen before but it was obscured by the
-- "store provider in localstorage then put a message on the bus" approach.
authenticate
  ∷ ∀ eff
  . Ref (Maybe (Promise EIdToken))
  → RequestIdTokenMessage
  → Aff (AuthEffects eff) Unit
authenticate stateRef message = do
  state ← liftEff $ Ref.readRef stateRef
  case state of
    Nothing → do
      idTokenPromise ← getIdToken message.providerR message.prompt
      writeState $ Just idTokenPromise
      void $ Aff.forkAff $ reply idTokenPromise *> writeState Nothing
    Just idTokenPromise → do
      void $ Aff.forkAff $ reply idTokenPromise
  where
  writeState ∷ Maybe (Promise EIdToken) → Aff (AuthEffects eff) Unit
  writeState = liftEff ∘ Ref.writeRef stateRef

  reply ∷ Promise EIdToken → Aff (AuthEffects eff) Unit
  reply = AVar.putVar message.idToken <=< Promise.wait

getIdTokenSilently
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenSilently providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  appendHiddenRequestIFrameToBody unhashedNonce providerR
    >>= case _ of
      Left error → pure $ Left error
      Right iFrameNode → do
        liftEff $ removeBodyChild iFrameNode
        race (getIdTokenFromLSOnChange providerR unhashedNonce) timeout
  where
  appendHiddenRequestIFrameToBody unhashedNonce providerR =
    either
      (pure ∘ Left)
      (liftEff ∘ map (lmap DOMError) ∘ appendHiddenIFrameToBody)
      =<< getAuthenticationUri OIDCAff.None unhashedNonce providerR
  timeout =
    Aff.later' Config.authenticationTimeout
      $ pure $ Left $ IdTokenUnavailable "No id token received before timeout."

getIdTokenUsingPrompt
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenUsingPrompt providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  race
    (getIdTokenFromLSOnChange providerR unhashedNonce)
    (prompt unhashedNonce)
  where
  popup src =
    (liftEff (DOMUtils.openPopup src) >>= DOMUtils.waitUntilWindowClosed)
      *> Aff.later' 250 (pure $ Left PromptDismissed)
  prompt unhashedNonce =
    (either (pure ∘ Left) popup)
      =<< getAuthenticationUri OIDCAff.Login unhashedNonce providerR

getAuthenticationUri
  ∷ ∀ eff
  . OIDCAff.Prompt
  → UnhashedNonce
  → ProviderR
  → Aff (AuthEffects eff) (Either AuthenticationError String)
getAuthenticationUri prompt unhashedNonce providerR =
  (bimap (ProviderError ∘ runParseError) id)
    <$> (liftEff
           $ OIDCAff.getAuthenticationUri prompt unhashedNonce providerR
           =<< getRedirectUri)

appendHiddenIFrameToBody ∷ ∀ eff. String → Eff (AuthEffects eff) (Either String Node)
appendHiddenIFrameToBody uri =
  either
    (pure ∘ Left)
    (appendIFrameToBody <=< configureHiddenIFrame uri)
    =<< createIFrameElement

configureHiddenIFrame
  ∷ ∀ eff
  . String
  → HTMLIFrameElement
  → Eff (AuthEffects eff) HTMLIFrameElement
configureHiddenIFrame uri iFrameElement = do
  DOMHTMLIFrameElement.setSrc uri iFrameElement
  DOMHTMLIFrameElement.setWidth "0" iFrameElement
  DOMHTMLIFrameElement.setHeight "0" iFrameElement
  pure iFrameElement

appendIFrameToBody
  ∷ ∀ eff
  . HTMLIFrameElement
  → Eff (AuthEffects eff) (Either String Node)
appendIFrameToBody iFrameElement =
  traverse (appendIFrameToNode iFrameElement) =<< getBodyNode

appendIFrameToNode
  ∷ ∀ eff
  . HTMLIFrameElement
  → Node
  → Eff (AuthEffects eff) Node
appendIFrameToNode iFrameElement node =
  passover (flip DOMNode.appendChild node)
    $ DOMHTMLTypes.htmlElementToNode
    $ DOMHTMLTypes.htmlIFrameElementToHTMLElement iFrameElement

createIFrameElement ∷ ∀ eff. Eff (AuthEffects eff) (Either String HTMLIFrameElement)
createIFrameElement =
  (lmap show ∘ DOMHTMLTypes.readHTMLIFrameElement ∘ Foreign.toForeign)
    <$> createElement "iframe"

createElement ∷ ∀ eff.  String → Eff (AuthEffects eff) Element
createElement name =
  DOMNodeDocument.createElement name
    ∘ DOMHTMLTypes.htmlDocumentToDocument
    =<< DOMHTMLWindow.document
    =<< DOMHTML.window

removeBodyChild ∷ ∀ eff.  Node → Eff (AuthEffects eff) (Either String Node)
removeBodyChild child =
  either (pure ∘ Left) (map Right ∘ DOMNode.removeChild child) =<< getBodyNode

getBodyNode ∷ ∀ eff. Eff (AuthEffects eff) (Either String Node)
getBodyNode =
  toEitherStringNode
    <$> (DOMHTMLDocument.body =<< DOMHTMLWindow.document =<< DOMHTML.window)
  where
  toEitherStringNode =
    maybe
      (Left "Couldn't find body element.")
      Right
      ∘ map DOMHTMLTypes.htmlElementToNode
      ∘ Nullable.toMaybe

getIdToken
  ∷ ∀ eff
  . ProviderR
  → Boolean
  → Aff (AuthEffects eff) (Promise EIdToken)
getIdToken providerR prompt =
  Promise.defer do
    idToken ← if prompt
      then
        getIdTokenUsingPrompt providerR
      else
        getIdTokenUsingLocalStorage providerR
          >>= maybe (getIdTokenSilently providerR) (pure ∘ Right)
    -- Store provider for future local storage gets and reauthentications
    either
      (const $ liftEff $ AuthStore.clearProvider *> AuthStore.clearIdToken)
      (const $ liftEff $ AuthStore.storeProvider $ QAT.Provider providerR)
      idToken
    pure idToken

getIdTokenUsingLocalStorage ∷ ∀ eff. ProviderR → Aff (AuthEffects eff) (Maybe IdToken)
getIdTokenUsingLocalStorage providerR = do
  eitherIdToken ← getUnverifiedIdTokenUsingLocalStorage
  eitherUnhashedNonce ← getUnhashedNonceUsingLocalStorage
  case Tuple eitherIdToken eitherUnhashedNonce of
    Tuple (Right idToken) (Right unhashedNonce) →
      liftEff $ verify providerR unhashedNonce idToken
        >>= if _ then (pure $ Just idToken) else (pure Nothing)
    Tuple _ _ → pure Nothing

getUnverifiedIdTokenUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenUsingLocalStorage =
  flip bind (map IdToken)
    <$> LocalStorage.getLocalStorage AuthKeys.idTokenLocalStorageKey

getUnhashedNonceUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String UnhashedNonce)
getUnhashedNonceUsingLocalStorage =
  rmap UnhashedNonce <$> LocalStorage.getLocalStorage AuthKeys.nonceLocalStorageKey

getProviderRUsingLocalStorage ∷ ∀ eff. Eff (AuthEffects eff) (Either String QAT.ProviderR)
getProviderRUsingLocalStorage =
  map QAT.runProvider <$> LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey

getIdTokenFromLSOnChange
  ∷ ∀ eff
  . ProviderR
  → UnhashedNonce
  → Aff (AuthEffects eff) EIdToken
getIdTokenFromLSOnChange providerR unhashedNonce =
  getUnverifiedIdTokenFromLSOnChange
    >>= case _ of
          Left localStorageError →
            pure $ Left $ IdTokenUnavailable localStorageError
          Right idToken →
            liftEff $ verify providerR unhashedNonce idToken
              >>= if _ then pure $ Right idToken else pure $ Left IdTokenInvalid

getUnverifiedIdTokenFromLSOnChange
  ∷ ∀ eff
  . Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenFromLSOnChange =
  _.newValue <$> (firstValueFromStallingProducer =<< liftEff getIdTokenStorageEvents)

runParseError ∷ ParseError → String
runParseError (ParseError s) = s

verify ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → Eff (AuthEffects eff) Boolean
verify providerR unhashedNonce idToken =
  F.or
    <$> T.traverse
          (verifyWithJwk providerR unhashedNonce idToken)
          providerR.openIDConfiguration.jwks

verifyWithJwk ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → JSONWebKey → Eff (AuthEffects eff) Boolean
verifyWithJwk providerR unhashedNonce idToken jwk = do
  OIDCCrypt.verifyIdToken
      idToken
      providerR.openIDConfiguration.issuer
      providerR.clientID
      unhashedNonce
      jwk

getRedirectUri ∷ ∀ eff. Eff (AuthEffects eff) String
getRedirectUri = (_ <> Config.redirectURIString) <$> Browser.locationString

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Quasar.Auth.Authentication
  ( authentication
  , getIdTokenFromBusSilently
  , fromEither
  , fromEitherEither
  , AuthEffects
  , EIdToken
  , AuthenticationError(..)
  , RequestIdTokenBus
  , RequestIdTokenMessage
  ) where

import Control.Coroutine as Coroutine
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as StallingCoroutine
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVAR, AffAVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus (BusRW, BusW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Aff.Promise (Promise)
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Ref (Ref, REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Rec.Class (forever)
import Control.Parallel.Class (race)
import Control.UI.Browser as Browser
import DOM (DOM)
import DOM.HTML as DOMHTML
import DOM.HTML.Document as DOMHTMLDocument
import DOM.HTML.HTMLIFrameElement as DOMHTMLIFrameElement
import DOM.HTML.Types (HTMLIFrameElement)
import DOM.HTML.Types as DOMHTMLTypes
import DOM.HTML.Window as DOMHTMLWindow
import DOM.Node.Document as DOMNodeDocument
import DOM.Node.Node as DOMNode
import DOM.Node.Types (Node, Element)
import Data.Either as E
import Data.Foldable as F
import Data.Foreign as Foreign
import Data.Maybe as M
import Data.Nullable as Nullable
import Data.Traversable as T
import OIDC.Aff as OIDCAff
import OIDC.Crypt (RSASIGNTIME)
import OIDC.Crypt as OIDCCrypt
import OIDC.Crypt.JSONWebKey (JSONWebKey)
import OIDC.Crypt.Types (IdToken(..), UnhashedNonce(..))
import Quasar.Advanced.Types (ProviderR)
import Quasar.Advanced.Types as QAT
import SlamData.Config as Config
import SlamData.Prelude
import SlamData.Quasar.Auth.IdTokenStorageEvents (getIdTokenStorageEvents)
import SlamData.Quasar.Auth.Keys as AuthKeys
import SlamData.Quasar.Auth.Store as AuthStore

import Text.Parsing.StringParser (ParseError(..))

import Utils (passover)
import Utils.LocalStorage as LocalStorage
import Utils.DOM as DOMUtils

fromEither ∷ ∀ a b. E.Either a b → M.Maybe b
fromEither = E.either (\_ → M.Nothing) (M.Just)

fromEitherEither ∷ ∀ a b c. E.Either a (E.Either b c) → M.Maybe c
fromEitherEither = E.either (\_ → M.Nothing) fromEither

getIdTokenFromBusSilently ∷ ∀ eff. RequestIdTokenBus → Aff (AuthEffects eff) (Either String EIdToken)
getIdTokenFromBusSilently requestNewIdTokenBus =
  liftEff getProviderRUsingLocalStorage
    >>= case _ of
      Right providerR → do
        idTokenVar ← AVar.makeVar
        Bus.write { idToken: idTokenVar, providerR, prompt: false } requestNewIdTokenBus
        idToken ← Right <$> AVar.takeVar idTokenVar
        pure idToken
      Left error → pure $ Left error

data AuthenticationError
  = IdTokenInvalid
  | IdTokenUnavailable String
  | PromptDismissed
  | DOMError String
  | ProviderError String

instance semigroupAuthenticationError ∷ Semigroup AuthenticationError where
  append x y = y

type RequestIdTokenMessage = { providerR ∷ ProviderR, prompt ∷ Boolean, idToken ∷ AVar EIdToken }

type RequestIdTokenBus = BusW RequestIdTokenMessage

type EIdToken = Either AuthenticationError IdToken

type AuthEffects eff =
  ( rsaSignTime ∷ RSASIGNTIME
  , avar ∷ AVAR
  , ref ∷ REF
  , dom ∷ DOM
  , random ∷ RANDOM
  | eff)

firstValueFromStallingProducer
  ∷ forall o eff
  . StallingCoroutine.StallingProducer o (Aff (avar ∷ AVAR | eff)) Unit
  → AffAVar eff o
firstValueFromStallingProducer producer = do
  firstValue ← AVar.makeVar
  Aff.forkAff
    $ StallingCoroutine.runStallingProcess
        (producer $$? (Coroutine.consumer \o → liftAff (AVar.putVar firstValue o) $> Just unit))
  val ← AVar.takeVar firstValue
  traceAnyA val
  pure val

writeOnlyBus ∷ ∀ a. BusRW a → BusW a
writeOnlyBus = snd ∘ Bus.split

-- | Write an AVar to the returned bus to get a valid OIDC id token from the given provider.
authentication ∷ ∀ eff. Aff (AuthEffects eff) RequestIdTokenBus
authentication = do
  stateRef ← liftEff $ Ref.newRef Nothing
  requestBus ← Bus.make
  Aff.forkAff $ forever (authenticate stateRef =<< Bus.read requestBus)
  pure $ writeOnlyBus requestBus

-- TODO: Allow multiple concurrent auth requests with different providers
-- and prompt options. Alternatively immediately respond with an
-- "authentication already in progress" error.
--
-- Currently if a message comes in whilst authentication is in progress the
-- sender will be given the id token from the in progress auth regardless of
-- what provider they asked for.
--
-- In current use this won't happen but it could if things change.
--
-- The same thing and worse could happen before but it was obscured by the
-- "store provider in localstorage then put a message on the bus" approach.
authenticate
  ∷ ∀ eff
  . Ref (Maybe (Promise EIdToken))
  → RequestIdTokenMessage
  → Aff (AuthEffects eff) Unit
authenticate stateRef message = do
  state ← liftEff $ Ref.readRef stateRef
  case state of
    Nothing → do
      idTokenPromise ← getIdToken message.providerR message.prompt
      writeState $ Just idTokenPromise
      void $ Aff.forkAff $ reply idTokenPromise *> writeState Nothing
    Just idTokenPromise → do
      void $ Aff.forkAff $ reply idTokenPromise
  where
  writeState ∷ Maybe (Promise EIdToken) → Aff (AuthEffects eff) Unit
  writeState = liftEff ∘ Ref.writeRef stateRef

  reply ∷ Promise EIdToken → Aff (AuthEffects eff) Unit
  reply = AVar.putVar message.idToken <=< Promise.wait

getIdTokenSilently
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenSilently providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  appendHiddenRequestIFrameToBody unhashedNonce providerR
    >>= case _ of
      Left error → pure $ Left error
      Right iFrameNode → do
        liftEff $ removeBodyChild iFrameNode
        race (getIdTokenFromLSOnChange providerR unhashedNonce) timeout
  where
  appendHiddenRequestIFrameToBody unhashedNonce providerR =
    either
      (pure ∘ Left)
      (liftEff ∘ map (lmap DOMError) ∘ appendHiddenIFrameToBody)
      =<< getAuthenticationUri OIDCAff.None unhashedNonce providerR
  timeout =
    Aff.later' Config.authenticationTimeout
      $ pure $ Left $ IdTokenUnavailable "No id token received before timeout."

getIdTokenUsingPrompt
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenUsingPrompt providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  race
    (getIdTokenFromLSOnChange providerR unhashedNonce)
    (prompt unhashedNonce)
  where
  popup src =
    (liftEff (DOMUtils.openPopup src) >>= DOMUtils.waitUntilWindowClosed)
      *> Aff.later' 250 (pure $ Left PromptDismissed)
  prompt unhashedNonce =
    (either (pure ∘ Left) popup)
      =<< getAuthenticationUri OIDCAff.Login unhashedNonce providerR

getAuthenticationUri
  ∷ ∀ eff
  . OIDCAff.Prompt
  → UnhashedNonce
  → ProviderR
  → Aff (AuthEffects eff) (Either AuthenticationError String)
getAuthenticationUri prompt unhashedNonce providerR =
  (bimap (ProviderError ∘ runParseError) id)
    <$> (liftEff
           $ OIDCAff.getAuthenticationUri prompt unhashedNonce providerR
           =<< getRedirectUri)

appendHiddenIFrameToBody ∷ ∀ eff. String → Eff (AuthEffects eff) (Either String Node)
appendHiddenIFrameToBody uri =
  either
    (pure ∘ Left)
    (appendIFrameToBody <=< configureHiddenIFrame uri)
    =<< createIFrameElement

configureHiddenIFrame
  ∷ ∀ eff
  . String
  → HTMLIFrameElement
  → Eff (AuthEffects eff) HTMLIFrameElement
configureHiddenIFrame uri iFrameElement = do
  DOMHTMLIFrameElement.setSrc uri iFrameElement
  DOMHTMLIFrameElement.setWidth "0" iFrameElement
  DOMHTMLIFrameElement.setHeight "0" iFrameElement
  pure iFrameElement

appendIFrameToBody
  ∷ ∀ eff
  . HTMLIFrameElement
  → Eff (AuthEffects eff) (Either String Node)
appendIFrameToBody iFrameElement =
  traverse (appendIFrameToNode iFrameElement) =<< getBodyNode

appendIFrameToNode
  ∷ ∀ eff
  . HTMLIFrameElement
  → Node
  → Eff (AuthEffects eff) Node
appendIFrameToNode iFrameElement node =
  passover (flip DOMNode.appendChild node)
    $ DOMHTMLTypes.htmlElementToNode
    $ DOMHTMLTypes.htmlIFrameElementToHTMLElement iFrameElement

createIFrameElement ∷ ∀ eff. Eff (AuthEffects eff) (Either String HTMLIFrameElement)
createIFrameElement =
  (lmap show ∘ DOMHTMLTypes.readHTMLIFrameElement ∘ Foreign.toForeign)
    <$> createElement "iframe"

createElement ∷ ∀ eff.  String → Eff (AuthEffects eff) Element
createElement name =
  DOMNodeDocument.createElement name
    ∘ DOMHTMLTypes.htmlDocumentToDocument
    =<< DOMHTMLWindow.document
    =<< DOMHTML.window

removeBodyChild ∷ ∀ eff.  Node → Eff (AuthEffects eff) (Either String Node)
removeBodyChild child =
  either (pure ∘ Left) (map Right ∘ DOMNode.removeChild child) =<< getBodyNode

getBodyNode ∷ ∀ eff. Eff (AuthEffects eff) (Either String Node)
getBodyNode =
  toEitherStringNode
    <$> (DOMHTMLDocument.body =<< DOMHTMLWindow.document =<< DOMHTML.window)
  where
  toEitherStringNode =
    maybe
      (Left "Couldn't find body element.")
      Right
      ∘ map DOMHTMLTypes.htmlElementToNode
      ∘ Nullable.toMaybe

getIdToken
  ∷ ∀ eff
  . ProviderR
  → Boolean
  → Aff (AuthEffects eff) (Promise EIdToken)
getIdToken providerR prompt =
  Promise.defer do
    idToken ← if prompt
      then
        getIdTokenUsingPrompt providerR
      else
        getIdTokenUsingLocalStorage providerR
          >>= maybe (getIdTokenSilently providerR) (pure ∘ Right)
    -- Store provider for future local storage gets and reauthentications
    traceAnyA idToken
    either
      (const $ liftEff $ AuthStore.clearProvider *> AuthStore.clearIdToken)
      (const $ liftEff $ AuthStore.storeProvider $ QAT.Provider providerR)
      idToken
    pure idToken

getIdTokenUsingLocalStorage ∷ ∀ eff. ProviderR → Aff (AuthEffects eff) (Maybe IdToken)
getIdTokenUsingLocalStorage providerR = do
  eitherIdToken ← getUnverifiedIdTokenUsingLocalStorage
  eitherUnhashedNonce ← getUnhashedNonceUsingLocalStorage
  case Tuple eitherIdToken eitherUnhashedNonce of
    Tuple (Right idToken) (Right unhashedNonce) →
      liftEff $ verify providerR unhashedNonce idToken
        >>= if _ then (pure $ Just idToken) else (pure Nothing)
    Tuple _ _ → pure Nothing

getUnverifiedIdTokenUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenUsingLocalStorage =
  flip bind (map IdToken)
    <$> LocalStorage.getLocalStorage AuthKeys.idTokenLocalStorageKey

getUnhashedNonceUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String UnhashedNonce)
getUnhashedNonceUsingLocalStorage =
  rmap UnhashedNonce <$> LocalStorage.getLocalStorage AuthKeys.nonceLocalStorageKey

getProviderRUsingLocalStorage ∷ ∀ eff. Eff (AuthEffects eff) (Either String QAT.ProviderR)
getProviderRUsingLocalStorage =
  map QAT.runProvider <$> LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey

getIdTokenFromLSOnChange
  ∷ ∀ eff
  . ProviderR
  → UnhashedNonce
  → Aff (AuthEffects eff) EIdToken
getIdTokenFromLSOnChange providerR unhashedNonce =
  getUnverifiedIdTokenFromLSOnChange
    >>= case _ of
          Left localStorageError →
            pure $ Left $ IdTokenUnavailable localStorageError
          Right idToken →
            liftEff $ verify providerR unhashedNonce idToken
              >>= if _ then pure $ Right idToken else pure $ Left IdTokenInvalid

getUnverifiedIdTokenFromLSOnChange
  ∷ ∀ eff
  . Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenFromLSOnChange =
  _.newValue <$> (firstValueFromStallingProducer =<< liftEff getIdTokenStorageEvents)

runParseError ∷ ParseError → String
runParseError (ParseError s) = s

verify ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → Eff (AuthEffects eff) Boolean
verify providerR unhashedNonce idToken =
  F.or
    <$> T.traverse
          (verifyWithJwk providerR unhashedNonce idToken)
          providerR.openIDConfiguration.jwks

verifyWithJwk ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → JSONWebKey → Eff (AuthEffects eff) Boolean
verifyWithJwk providerR unhashedNonce idToken jwk = do
  OIDCCrypt.verifyIdToken
      idToken
      providerR.openIDConfiguration.issuer
      providerR.clientID
      unhashedNonce
      jwk

getRedirectUri ∷ ∀ eff. Eff (AuthEffects eff) String
getRedirectUri = (_ <> Config.redirectURIString) <$> Browser.locationString