Add examples to docs for Data.String.CodePoints (#94)

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in `Data.String`.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , codePointFromChar
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char (toCharCode)
import Data.Char as Char
import Data.Int (hexadecimal, toStringAs)
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: If a new function is added to Data.String, a version of that function
-- should be exported from this module, which should be the same except that it
-- should operate on the code point level rather than the code unit level. If
-- the function's behaviour does not change based on whether we consider
-- strings as sequences of code points or code units, it can simply be
-- re-exported from Data.String.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

instance showCodePoint :: Show CodePoint where
  show (CodePoint i) = "(CodePoint 0x" <> String.toUpper (toStringAs hexadecimal i) <> ")"

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
-- |
-- | ```purescript
-- | >>> it = codePointFromInt 0x1D400 -- U+1D400 MATHEMATICAL BOLD CAPITAL A
-- | Just (CodePoint 0x1D400)
-- |
-- | >>> map singleton it
-- | Just "𝐀"
-- |
-- | >>> codePointFromInt 0x110000 -- does not correspond to a Unicode code point
-- | Nothing
-- | ```
-- |
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

-- |
-- | ```purescript
-- | >>> codePointToInt (codePointFromChar 'B')
-- | 66
-- |
-- | >>> boldA = codePointFromInt 0x1D400
-- | >>> boldA
-- | Just (CodePoint 0x1D400)
-- | >>> map codePointToInt boldA
-- | Just 119808 -- is the same as 0x1D400
-- | ```
-- |
codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

-- | Creates a CodePoint from a given Char.
-- |
-- | ```purescript
-- | >>> codePointFromChar 'B'
-- | CodePoint 0x42 -- represents 'B'
-- | ```
-- |
codePointFromChar :: Char -> CodePoint
codePointFromChar = toCharCode >>> CodePoint

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

-- WARN: this function expects the String parameter to be non-empty
unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  let cu0 = Unsafe.charCodeAt 0 s in
  let cu1 = Unsafe.charCodeAt 1 s in
  if isLead cu0 && isTrail cu1
     then unsurrogate cu0 cu1
     else CodePoint cu0

-- | Returns the first code point of the string after dropping the given number
-- | of code points from the beginning, if there is such a code point. Operates
-- | in constant space and in time linear to the given index.
-- |
-- | ```purescript
-- | >>> codePointAt 1 "𝐀𝐀𝐀𝐀"
-- | Just (CodePoint 0x1D400) -- represents "𝐀"
-- | -- compare to Data.String:
-- | >>> charAt 1 "𝐀𝐀𝐀𝐀"
-- | Just '�'
-- | ```
-- |
codePointAt :: Int -> String -> Maybe CodePoint
codePointAt n _ | n < 0 = Nothing
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = case uncons s of
  Just { head, tail } -> if n == 0 then Just head else codePointAtFallback (n - 1) tail
  _ -> Nothing

-- | Returns the number of code points in the leading sequence of code points
-- | which all match the given predicate. Operates in constant space and in
-- | time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> count (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | 2
-- | ```
-- |
count :: (CodePoint -> Boolean) -> String -> Int
count = _count countFallback unsafeCodePointAt0

foreign import _count
  :: ((CodePoint -> Boolean) -> String -> Int)
  -> (String -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

countFallback :: (CodePoint -> Boolean) -> String -> Int
countFallback p s = countTail p s 0

countTail :: (CodePoint -> Boolean) -> String -> Int -> Int
countTail p s accum = case uncons s of
  Just { head, tail } -> if p head then countTail p tail (accum + 1) else accum
  _ -> accum

-- | Drops the given number of code points from the beginning of the string. If
-- | the string does not have that many code points, returns the empty string.
-- | Operates in constant space and in time linear to the given number.
-- |
-- | ```purescript
-- | >>> drop 5 "𝐀𝐀 b c"
-- | "c"
-- | -- compared to Data.String:
-- | >>> drop 5 "𝐀𝐀 b c"
-- | "b c" -- because "𝐀" occupies 2 code units
-- | ```
-- |
drop :: Int -> String -> String
drop n s = String.drop (String.length (take n s)) s

-- | Drops the leading sequence of code points which all match the given
-- | predicate from the string. Operates in constant space and in time linear
-- | to the length of the string.
-- |
-- | ```purescript
-- | >>> dropWhile (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | " b c 𝐀"
-- | ```
-- |
dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | Creates a string from an array of code points. Operates in space and time
-- | linear to the length of the array.
-- |
-- | ```purescript
-- | >>> codePointArray = toCodePointArray "c 𝐀"
-- | >>> codePointArray
-- | [CodePoint 0x63, CodePoint 0x20, CodePoint 0x1D400]
-- | >>> fromCodePointArray codePointArray
-- | "c 𝐀"
-- | ```
-- |
fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> indexOf (Pattern "𝐀") "b 𝐀𝐀 c 𝐀"
-- | Just 2
-- | >>> indexOf (Pattern "o") "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches preceding the given index will be
-- | ignored. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> indexOf' (Pattern "𝐀") 4 "b 𝐀𝐀 c 𝐀"
-- | Just 7
-- | >>> indexOf' (Pattern "o") 4 "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

-- | Returns the number of code points preceding the last match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> lastIndexOf (Pattern "𝐀") "b 𝐀𝐀 c 𝐀"
-- | Just 7
-- | >>> lastIndexOf (Pattern "o") "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches following the given index will be
-- | ignored. Returns Nothing when no matches are found.
-- |
-- | ```purescript
-- | >>> lastIndexOf' (Pattern "𝐀") 5 "b 𝐀𝐀 c 𝐀"
-- | Just 3
-- | >>> lastIndexOf' (Pattern "o") 5 "b 𝐀𝐀 c 𝐀"
-- | Nothing
-- | ```
-- |
lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = String.length (take i s) in
  (\k -> length (String.take k s)) <$> String.lastIndexOf' p i' s

-- | Returns the number of code points in the string. Operates in constant
-- | space and in time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> length "b 𝐀𝐀 c 𝐀"
-- | 8
-- | -- compare to Data.String:
-- | >>> length "b 𝐀𝐀 c 𝐀"
-- | 11
-- | ```
-- |
length :: String -> Int
length = Array.length <<< toCodePointArray

-- | Creates a string containing just the given code point. Operates in
-- | constant space and time.
-- |
-- | ```purescript
-- | >>> map singleton (codePointFromInt 0x1D400)
-- | Just "𝐀"
-- | ```
-- |
singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) =
  let lead = ((cp - 0x10000) / 0x400) + 0xD800 in
  let trail = (cp - 0x10000) `mod` 0x400 + 0xDC00 in
  fromCharCode lead <> fromCharCode trail

-- | Returns a record with strings created from the code points on either side
-- | of the given index. If the index is not within the string, Nothing is
-- | returned.
-- |
-- | ```purescript
-- | >>> splitAt 3 "b 𝐀𝐀 c 𝐀"
-- | Just { before: "b 𝐀", after: "𝐀 c 𝐀" }
-- | ```
-- |
splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps < i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

-- | Returns a string containing the given number of code points from the
-- | beginning of the given string. If the string does not have that many code
-- | points, returns the empty string. Operates in constant space and in time
-- | linear to the given number.
-- |
-- | ```purescript
-- | >>> take 3 "b 𝐀𝐀 c 𝐀"
-- | "b 𝐀"
-- | -- compare to Data.String:
-- | >>> take 3 "b 𝐀𝐀 c 𝐀"
-- | "b �"
-- | ```
-- |
take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n _ | n < 1 = ""
takeFallback n s = case uncons s of
  Just { head, tail } -> singleton head <> takeFallback (n - 1) tail
  _ -> s

-- | Returns a string containing the leading sequence of code points which all
-- | match the given predicate from the string. Operates in constant space and
-- | in time linear to the length of the string.
-- |
-- | ```purescript
-- | >>> takeWhile (\c -> codePointToInt c == 0x1D400) "𝐀𝐀 b c 𝐀"
-- | "𝐀𝐀"
-- | ```
-- |
takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Creates an array of code points from a string. Operates in space and time
-- | linear to the length of the string.
-- |
-- | ```purescript
-- | >>> codePointArray = toCodePointArray "b 𝐀𝐀"
-- | >>> codePointArray
-- | [CodePoint 0x62, CodePoint 0x20, CodePoint 0x1D400, CodePoint 0x1D400]
-- | >>> map singleton codePointArray
-- | ["b", " ", "𝐀", "𝐀", " ", "c", " ", "𝐀"]
-- | ```
-- |
toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr unconsButWithTuple s

unconsButWithTuple :: String -> Maybe (Tuple CodePoint String)
unconsButWithTuple s = (\{ head, tail } -> Tuple head tail) <$> uncons s

-- | Returns a record with the first code point and the remaining code points
-- | of the string. Returns Nothing if the string is empty. Operates in
-- | constant space and time.
-- |
-- | ```purescript
-- | >>> uncons "𝐀𝐀 c 𝐀"
-- | Just { head: CodePoint 0x1D400, tail: "𝐀 c 𝐀" }
-- | >>> uncons ""
-- | Nothing
-- | ```
-- |
uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s = case String.length s of
  0 -> Nothing
  1 -> Just { head: CodePoint (Unsafe.charCodeAt 0 s), tail: "" }
  _ ->
    let cu0 = Unsafe.charCodeAt 0 s in
    let cu1 = Unsafe.charCodeAt 1 s in
    if isLead cu0 && isTrail cu1
      then Just { head: unsurrogate cu0 cu1, tail: String.drop 2 s }
      else Just { head: CodePoint cu0, tail: String.drop 1 s }

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in Data.String.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , codePointFromChar
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char (toCharCode)
import Data.Char as Char
import Data.Int (hexadecimal, toStringAs)
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: If a new function is added to Data.String, a version of that function
-- should be exported from this module, which should be the same except that it
-- should operate on the code point level rather than the code unit level. If
-- the function's behaviour does not change based on whether we consider
-- strings as sequences of code points or code units, it can simply be
-- re-exported from Data.String.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

instance showCodePoint :: Show CodePoint where
  show (CodePoint i) = "(CodePoint 0x" <> String.toUpper (toStringAs hexadecimal i) <> ")"

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

-- | Creates a CodePoint from a given Char.
-- |
-- | ```purescript
-- | >>> codePointFromChar 'B'
-- | CodePoint 0x42 -- represents 'B'
-- | ```
-- |
codePointFromChar :: Char -> CodePoint
codePointFromChar = toCharCode >>> CodePoint

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

-- WARN: this function expects the String parameter to be non-empty
unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  let cu0 = Unsafe.charCodeAt 0 s in
  let cu1 = Unsafe.charCodeAt 1 s in
  if isLead cu0 && isTrail cu1
     then unsurrogate cu0 cu1
     else CodePoint cu0

-- | Returns the first code point of the string after dropping the given number
-- | of code points from the beginning, if there is such a code point. Operates
-- | in constant space and in time linear to the given index.
codePointAt :: Int -> String -> Maybe CodePoint
codePointAt n _ | n < 0 = Nothing
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = case uncons s of
  Just { head, tail } -> if n == 0 then Just head else codePointAtFallback (n - 1) tail
  _ -> Nothing

-- | Returns the number of code points in the leading sequence of code points
-- | which all match the given predicate. Operates in constant space and in
-- | time linear to the length of the string.
count :: (CodePoint -> Boolean) -> String -> Int
count = _count countFallback unsafeCodePointAt0

foreign import _count
  :: ((CodePoint -> Boolean) -> String -> Int)
  -> (String -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

countFallback :: (CodePoint -> Boolean) -> String -> Int
countFallback p s = countTail p s 0

countTail :: (CodePoint -> Boolean) -> String -> Int -> Int
countTail p s accum = case uncons s of
  Just { head, tail } -> if p head then countTail p tail (accum + 1) else accum
  _ -> accum

-- | Drops the given number of code points from the beginning of the string. If
-- | the string does not have that many code points, returns the empty string.
-- | Operates in constant space and in time linear to the given number.
drop :: Int -> String -> String
drop n s = String.drop (String.length (take n s)) s

-- | Drops the leading sequence of code points which all match the given
-- | predicate from the string. Operates in constant space and in time linear
-- | to the length of the string.
dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | Creates a string from an array of code points. Operates in space and time
-- | linear to the length of the array.
fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches preceding the given index will be
-- | ignored. Returns Nothing when no matches are found.
indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

-- | Returns the number of code points preceding the last match of the given
-- | pattern in the string. Returns Nothing when no matches are found.
lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the string. Pattern matches following the given index will be
-- | ignored. Returns Nothing when no matches are found.
lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = String.length (take i s) in
  (\k -> length (String.take k s)) <$> String.lastIndexOf' p i' s

-- | Returns the number of code points in the string. Operates in constant
-- | space and in time linear to the length of the string.
length :: String -> Int
length = Array.length <<< toCodePointArray

-- | Creates a string containing just the given code point. Operates in
-- | constant space and time.
singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) =
  let lead = ((cp - 0x10000) / 0x400) + 0xD800 in
  let trail = (cp - 0x10000) `mod` 0x400 + 0xDC00 in
  fromCharCode lead <> fromCharCode trail

-- | Returns a record with strings created from the code points on either side
-- | of the given index. If the index is not within the string, Nothing is
-- | returned.
splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps < i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

-- | Returns a string containing the given number of code points from the
-- | beginning of the given string. If the string does not have that many code
-- | points, returns the empty string. Operates in constant space and in time
-- | linear to the given number.
take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n _ | n < 1 = ""
takeFallback n s = case uncons s of
  Just { head, tail } -> singleton head <> takeFallback (n - 1) tail
  _ -> s

-- | Returns a string containing the leading sequence of code points which all
-- | match the given predicate from the string. Operates in constant space and
-- | in time linear to the length of the string.
takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Creates an array of code points from a string. Operates in space and time
-- | linear to the length of the string.
toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr unconsButWithTuple s

unconsButWithTuple :: String -> Maybe (Tuple CodePoint String)
unconsButWithTuple s = (\{ head, tail } -> Tuple head tail) <$> uncons s

-- | Returns a record with the first code point and the remaining code points
-- | of the string. Returns Nothing if the string is empty. Operates in
-- | constant space and time.
uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s = case String.length s of
  0 -> Nothing
  1 -> Just { head: CodePoint (Unsafe.charCodeAt 0 s), tail: "" }
  _ ->
    let cu0 = Unsafe.charCodeAt 0 s in
    let cu1 = Unsafe.charCodeAt 1 s in
    if isLead cu0 && isTrail cu1
      then Just { head: unsurrogate cu0 cu1, tail: String.drop 2 s }
      else Just { head: CodePoint cu0, tail: String.drop 1 s }


getcircle refactor

getcircle refactor

module Components.Helpers where

import Components.Init (defaultCircle)
import Components.Typer (Circle, State)
import Data.Array ((!!))
import Data.Maybe (Maybe(..), fromMaybe)
import Prelude ((#), (+), (-), (==))

getcircle :: State -> Int -> Circle
getcircle state i =
  case state.drag of
    Nothing -> thiscircle
    Just { start, current, index } ->
      if index == i then
        thiscircle { x = thiscircle.x + current.x - start.x
                   , y = thiscircle.y + current.y - start.y }
      else
        thiscircle
  where
  thiscircle = state.circles !! i # fromMaybe defaultCircle

module Components.Helpers where

import Components.Init (defaultCircle)
import Components.Typer (Circle, State)
import Data.Array ((!!))
import Data.Maybe (Maybe(..), fromMaybe)
import Prelude ((#), (+), (-), (==))

getcircle :: State -> Int -> Circle
getcircle state this =
  case state.drag of
    Nothing -> state.circles !! this # fromMaybe defaultCircle
    Just { start, current, index } ->
      let
        cirkel = state.circles !! this # fromMaybe defaultCircle
        x = if this == index then cirkel.x + current.x - start.x else cirkel.x
        y = if this == index then cirkel.y + current.y - start.y else cirkel.y
      in
        cirkel { x = x, y = y }


Fix exception when request body is undefined

-- Think twice before import this into your module, young jedi --
module Node.Express.Internal.Request where

import Data.Maybe
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Foreign.EasyFFI
import Node.Express.Internal.Utils
import Node.Express.Types
import Node.Express.Internal.QueryString

intlReqRouteParam ::
    forall a. (RequestParam a) =>
    Request -> a -> ExpressM (Maybe String)
intlReqRouteParam req name = do
    let getter :: forall a. Request -> a -> ExpressM Foreign
        getter = unsafeForeignFunction ["req", "name", ""] "req.params[name]"
    liftM1 (eitherToMaybe <<< read) (getter req name)

intlReqBodyParam ::
    forall a. (IsForeign a) =>
    Request -> String -> ExpressM (Maybe a)
intlReqBodyParam req name = do
    let getter = unsafeForeignFunction ["req", "name", ""]
                    "typeof req.body != 'undefined' && req.body[name] || undefined"
    liftM1 (eitherToMaybe <<< read) (getter req name)

intlReqQueryParams :: Request -> ExpressM [Param]
intlReqQueryParams req = do
    let getter = unsafeForeignFunction ["req", ""] "req.url.split('?')[1] || ''"
    query <- getter req
    case parse query of
        Left _ -> return []
        Right params -> return params

intlReqRoute ::
    Request -> ExpressM String
intlReqRoute = unsafeForeignFunction ["req", ""] "req.route.path"

intlReqGetCookie ::
    Request -> String -> ExpressM (Maybe String)
intlReqGetCookie req name = do
    let getter = unsafeForeignFunction ["req", "name", ""] "req.cookies[name]"
    liftM1 (eitherToMaybe <<< read) (getter req name)

intlReqGetSignedCookie ::
    Request -> String -> ExpressM (Maybe String)
intlReqGetSignedCookie req name = do
    let getter = unsafeForeignFunction ["req", "name", ""] "req.signedCookies[name]"
    liftM1 (eitherToMaybe <<< read) (getter req name)

intlReqGetHeader ::
    Request -> String -> ExpressM (Maybe String)
intlReqGetHeader req field = do
    let getter = unsafeForeignFunction ["req", "field", ""] "req.get(field);"
    liftM1 (eitherToMaybe <<< read) (getter req field)

intlReqAccepts :: Request -> String -> ExpressM (Maybe String)
intlReqAccepts req types = do
    let getter = unsafeForeignFunction ["req", "types", ""] "req.accepts(types);"
    liftM1 (eitherToMaybe <<< read) (getter req types)

intlReqAcceptsCharset :: Request -> String -> ExpressM (Maybe String)
intlReqAcceptsCharset req charset = do
    let getter = unsafeForeignFunction ["req", "charset", ""] "req.acceptsCharset(charset);"
    liftM1 (eitherToMaybe <<< read) (getter req charset)

intlReqAcceptsLanguage :: Request -> String -> ExpressM (Maybe String)
intlReqAcceptsLanguage req language = do
    let getter = unsafeForeignFunction ["req", "language", ""] "req.acceptsLanguage(language);"
    liftM1 (eitherToMaybe <<< read) (getter req language)

intlReqHasType :: Request -> String -> ExpressM Boolean
intlReqHasType req type_ = do
    let getter = unsafeForeignFunction ["req", "type", ""] "req.is(type);"
    val <- liftM1 (eitherToMaybe <<< read) (getter req type_)
    return $ fromMaybe false val

intlReqGetRemoteIp :: Request -> ExpressM String
intlReqGetRemoteIp = unsafeForeignFunction ["req", ""] "req.ip"

intlReqGetRemoteIps :: Request -> ExpressM [String]
intlReqGetRemoteIps = unsafeForeignFunction ["req", ""] "req.ips"

intlReqGetPath :: Request -> ExpressM String
intlReqGetPath = unsafeForeignFunction ["req", ""] "req.path"

intlReqGetHostname :: Request -> ExpressM String
intlReqGetHostname = unsafeForeignFunction ["req", ""] "req.hostname"

intlReqGetSubdomains :: Request -> ExpressM [String]
intlReqGetSubdomains = unsafeForeignFunction ["req", ""] "req.subdomains"

intlReqIsFresh :: Request -> ExpressM Boolean
intlReqIsFresh = unsafeForeignFunction ["req", ""] "req.fresh"

intlReqIsStale :: Request -> ExpressM Boolean
intlReqIsStale = unsafeForeignFunction ["req", ""] "req.stale"

intlReqIsXhr :: Request -> ExpressM Boolean
intlReqIsXhr = unsafeForeignFunction ["req", ""] "req.xhr"

intlReqGetProtocol :: Request -> ExpressM (Maybe Protocol)
intlReqGetProtocol req = do
    let getter = unsafeForeignFunction ["req", ""] "req.protocol"
    liftM1 (eitherToMaybe <<< read) (getter req)

intlReqGetMethod :: Request -> ExpressM (Maybe Method)
intlReqGetMethod req = do
    let getter = unsafeForeignFunction ["req", ""] "req.method"
    liftM1 (eitherToMaybe <<< read) (getter req)

intlReqGetUrl :: Request -> ExpressM String
intlReqGetUrl = unsafeForeignFunction ["req", ""] "req.url"

intlReqGetOriginalUrl :: Request -> ExpressM String
intlReqGetOriginalUrl = unsafeForeignFunction ["req", ""] "req.originalUrl"

-- Think twice before import this into your module, young jedi --
module Node.Express.Internal.Request where

import Data.Maybe
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Foreign.EasyFFI
import Node.Express.Internal.Utils
import Node.Express.Types
import Node.Express.Internal.QueryString

intlReqRouteParam ::
    forall a. (RequestParam a) =>
    Request -> a -> ExpressM (Maybe String)
intlReqRouteParam req name = do
    let getter :: forall a. Request -> a -> ExpressM Foreign
        getter = unsafeForeignFunction ["req", "name", ""] "req.params[name]"
    liftM1 (eitherToMaybe <<< read) (getter req name)

intlReqBodyParam ::
    forall a. (IsForeign a) =>
    Request -> String -> ExpressM (Maybe a)
intlReqBodyParam req name = do
    let getter = unsafeForeignFunction ["req", "name", ""] "req.body[name]"
    liftM1 (eitherToMaybe <<< read) (getter req name)

intlReqQueryParams :: Request -> ExpressM [Param]
intlReqQueryParams req = do
    let getter = unsafeForeignFunction ["req", ""] "req.url.split('?')[1] || ''"
    query <- getter req
    case parse query of
        Left _ -> return []
        Right params -> return params

intlReqRoute ::
    Request -> ExpressM String
intlReqRoute = unsafeForeignFunction ["req", ""] "req.route.path"

intlReqGetCookie ::
    Request -> String -> ExpressM (Maybe String)
intlReqGetCookie req name = do
    let getter = unsafeForeignFunction ["req", "name", ""] "req.cookies[name]"
    liftM1 (eitherToMaybe <<< read) (getter req name)

intlReqGetSignedCookie ::
    Request -> String -> ExpressM (Maybe String)
intlReqGetSignedCookie req name = do
    let getter = unsafeForeignFunction ["req", "name", ""] "req.signedCookies[name]"
    liftM1 (eitherToMaybe <<< read) (getter req name)

intlReqGetHeader ::
    Request -> String -> ExpressM (Maybe String)
intlReqGetHeader req field = do
    let getter = unsafeForeignFunction ["req", "field", ""] "req.get(field);"
    liftM1 (eitherToMaybe <<< read) (getter req field)

intlReqAccepts :: Request -> String -> ExpressM (Maybe String)
intlReqAccepts req types = do
    let getter = unsafeForeignFunction ["req", "types", ""] "req.accepts(types);"
    liftM1 (eitherToMaybe <<< read) (getter req types)

intlReqAcceptsCharset :: Request -> String -> ExpressM (Maybe String)
intlReqAcceptsCharset req charset = do
    let getter = unsafeForeignFunction ["req", "charset", ""] "req.acceptsCharset(charset);"
    liftM1 (eitherToMaybe <<< read) (getter req charset)

intlReqAcceptsLanguage :: Request -> String -> ExpressM (Maybe String)
intlReqAcceptsLanguage req language = do
    let getter = unsafeForeignFunction ["req", "language", ""] "req.acceptsLanguage(language);"
    liftM1 (eitherToMaybe <<< read) (getter req language)

intlReqHasType :: Request -> String -> ExpressM Boolean
intlReqHasType req type_ = do
    let getter = unsafeForeignFunction ["req", "type", ""] "req.is(type);"
    val <- liftM1 (eitherToMaybe <<< read) (getter req type_)
    return $ fromMaybe false val

intlReqGetRemoteIp :: Request -> ExpressM String
intlReqGetRemoteIp = unsafeForeignFunction ["req", ""] "req.ip"

intlReqGetRemoteIps :: Request -> ExpressM [String]
intlReqGetRemoteIps = unsafeForeignFunction ["req", ""] "req.ips"

intlReqGetPath :: Request -> ExpressM String
intlReqGetPath = unsafeForeignFunction ["req", ""] "req.path"

intlReqGetHostname :: Request -> ExpressM String
intlReqGetHostname = unsafeForeignFunction ["req", ""] "req.hostname"

intlReqGetSubdomains :: Request -> ExpressM [String]
intlReqGetSubdomains = unsafeForeignFunction ["req", ""] "req.subdomains"

intlReqIsFresh :: Request -> ExpressM Boolean
intlReqIsFresh = unsafeForeignFunction ["req", ""] "req.fresh"

intlReqIsStale :: Request -> ExpressM Boolean
intlReqIsStale = unsafeForeignFunction ["req", ""] "req.stale"

intlReqIsXhr :: Request -> ExpressM Boolean
intlReqIsXhr = unsafeForeignFunction ["req", ""] "req.xhr"

intlReqGetProtocol :: Request -> ExpressM (Maybe Protocol)
intlReqGetProtocol req = do
    let getter = unsafeForeignFunction ["req", ""] "req.protocol"
    liftM1 (eitherToMaybe <<< read) (getter req)

intlReqGetMethod :: Request -> ExpressM (Maybe Method)
intlReqGetMethod req = do
    let getter = unsafeForeignFunction ["req", ""] "req.method"
    liftM1 (eitherToMaybe <<< read) (getter req)

intlReqGetUrl :: Request -> ExpressM String
intlReqGetUrl = unsafeForeignFunction ["req", ""] "req.url"

intlReqGetOriginalUrl :: Request -> ExpressM String
intlReqGetOriginalUrl = unsafeForeignFunction ["req", ""] "req.originalUrl"


kill unnecessary code in StrMap singleton

-- | This module defines a type of native Javascript maps which
-- | require the keys to be strings.
-- |
-- | To maximize performance, Javascript objects are not wrapped,
-- | and some native code is used even when it's not necessary.

module Data.StrMap
  ( StrMap
  , empty
  , isEmpty
  , size
  , singleton
  , insert
  , lookup
  , toUnfoldable
  , toAscUnfoldable
  , fromFoldable
  , fromFoldableWith
  , delete
  , pop
  , member
  , alter
  , update
  , mapWithKey
  , keys
  , values
  , union
  , unions
  , isSubmap
  , fold
  , foldMap
  , foldM
  , foldMaybe
  , all
  , thawST
  , freezeST
  , runST
  , pureST
  ) where

import Prelude

import Control.Monad.Eff (Eff, runPure)
import Control.Monad.ST as ST

import Data.Array as A
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable, foldl, foldr, for_)
import Data.Function.Uncurried (Fn2, runFn2, Fn4, runFn4)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.StrMap.ST as SM
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..), fst)
import Data.Unfoldable (class Unfoldable)

-- | `StrMap a` represents a map from `String`s to values of type `a`.
foreign import data StrMap :: Type -> Type

foreign import _copyEff :: forall a b h r. a -> Eff (st :: ST.ST h | r) b

-- | Convert an immutable map into a mutable map
thawST :: forall a h r. StrMap a -> Eff (st :: ST.ST h | r) (SM.STStrMap h a)
thawST = _copyEff

-- | Convert a mutable map into an immutable map
freezeST :: forall a h r. SM.STStrMap h a -> Eff (st :: ST.ST h | r) (StrMap a)
freezeST = _copyEff

-- | Freeze a mutable map, creating an immutable map. Use this function as you would use
-- | `Prelude.runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the map from escaping the scope of `runST`.
foreign import runST :: forall a r. (forall h. Eff (st :: ST.ST h | r) (SM.STStrMap h a)) -> Eff r (StrMap a)

pureST :: forall a. (forall h e. Eff (st :: ST.ST h | e) (SM.STStrMap h a)) -> StrMap a
pureST f = runPure (runST f)

mutate :: forall a b. (forall h e. SM.STStrMap h a -> Eff (st :: ST.ST h | e) b) -> StrMap a -> StrMap a
mutate f m = pureST do
  s <- thawST m
  _ <- f s
  pure s

foreign import _fmapStrMap :: forall a b. Fn2 (StrMap a) (a -> b) (StrMap b)

instance functorStrMap :: Functor StrMap where
  map f m = runFn2 _fmapStrMap m f

foreign import _foldM :: forall a m z. (m -> (z -> m) -> m) -> (z -> String -> a -> m) -> m -> StrMap a -> m

-- | Fold the keys and values of a map
fold :: forall a z. (z -> String -> a -> z) -> z -> StrMap a -> z
fold = _foldM ((#))

-- | Fold the keys and values of a map, accumulating values using
-- | some `Monoid`.
foldMap :: forall a m. Monoid m => (String -> a -> m) -> StrMap a -> m
foldMap f = fold (\acc k v -> acc <> f k v) mempty

-- | Fold the keys and values of a map, accumulating values and effects in
-- | some `Monad`.
foldM :: forall a m z. Monad m => (z -> String -> a -> m z) -> z -> StrMap a -> m z
foldM f z = _foldM bind f (pure z)

instance foldableStrMap :: Foldable StrMap where
  foldl f = fold (\z _ -> f z)
  foldr f z m = foldr f z (values m)
  foldMap f = foldMap (const f)

instance traversableStrMap :: Traversable StrMap where
  traverse f ms = fold (\acc k v -> insert k <$> f v <*> acc) (pure empty) ms
  sequence = traverse id

-- Unfortunately the above are not short-circuitable (consider using purescript-machines)
-- so we need special cases:

foreign import _foldSCStrMap :: forall a z. Fn4 (StrMap a) z (z -> String -> a -> Maybe z) (forall b. b -> Maybe b -> b) z

-- | Fold the keys and values of a map.
-- |
-- | This function allows the folding function to terminate the fold early,
-- | using `Maybe`.
foldMaybe :: forall a z. (z -> String -> a -> Maybe z) -> z -> StrMap a -> z
foldMaybe f z m = runFn4 _foldSCStrMap m z f fromMaybe

-- | Test whether all key/value pairs in a `StrMap` satisfy a predicate.
foreign import all :: forall a. (String -> a -> Boolean) -> StrMap a -> Boolean

instance eqStrMap :: Eq a => Eq (StrMap a) where
  eq m1 m2 = (isSubmap m1 m2) && (isSubmap m2 m1)

instance eq1StrMap :: Eq1 StrMap where
  eq1 = eq

-- Internal use
toAscArray :: forall v. StrMap v -> Array (Tuple String v)
toAscArray = toAscUnfoldable

instance ordStrMap :: Ord a => Ord (StrMap a) where
  compare m1 m2 = compare (toAscArray m1) (toAscArray m2)

instance showStrMap :: Show a => Show (StrMap a) where
  show m = "(fromFoldable " <> show (toArray m) <> ")"

-- | An empty map
foreign import empty :: forall a. StrMap a

-- | Test whether one map contains all of the keys and values contained in another map
isSubmap :: forall a. Eq a => StrMap a -> StrMap a -> Boolean
isSubmap m1 m2 = all f m1 where
  f k v = runFn4 _lookup false ((==) v) k m2

-- | Test whether a map is empty
isEmpty :: forall a. StrMap a -> Boolean
isEmpty = all (\_ _ -> false)

-- | Calculate the number of key/value pairs in a map
foreign import size :: forall a. StrMap a -> Int

-- | Create a map with one key/value pair
singleton :: forall a. String -> a -> StrMap a
singleton k v = pureST do
  s <- SM.new
  SM.poke s k v

foreign import _lookup :: forall a z. Fn4 z (a -> z) String (StrMap a) z

-- | Lookup the value for a key in a map
lookup :: forall a. String -> StrMap a -> Maybe a
lookup = runFn4 _lookup Nothing Just

-- | Test whether a `String` appears as a key in a map
member :: forall a. String -> StrMap a -> Boolean
member = runFn4 _lookup false (const true)

-- | Insert or replace a key/value pair in a map
insert :: forall a. String -> a -> StrMap a -> StrMap a
insert k v = mutate (\s -> void $ SM.poke s k v)

foreign import _unsafeDeleteStrMap :: forall a. Fn2 (StrMap a) String (StrMap a)

-- | Delete a key and value from a map
delete :: forall a. String -> StrMap a -> StrMap a
delete k = mutate (\s -> void $ SM.delete s k)

-- | Delete a key and value from a map, returning the value
-- | as well as the subsequent map
pop :: forall a. String -> StrMap a -> Maybe (Tuple a (StrMap a))
pop k m = lookup k m <#> \a -> Tuple a (delete k m)

-- | Insert, remove or update a value for a key in a map
alter :: forall a. (Maybe a -> Maybe a) -> String -> StrMap a -> StrMap a
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Remove or update a value for a key in a map
update :: forall a. (a -> Maybe a) -> String -> StrMap a -> StrMap a
update f k m = alter (maybe Nothing f) k m

-- | Create a map from a foldable collection of key/value pairs
fromFoldable :: forall f a. Foldable f => f (Tuple String a) -> StrMap a
fromFoldable l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> SM.poke s k v)
  pure s)

foreign import _lookupST :: forall a h r z. Fn4 z (a -> z) String (SM.STStrMap h a) (Eff (st :: ST.ST h | r) z)

-- | Create a map from a foldable collection of key/value pairs, using the
-- | specified function to combine values for duplicate keys.
fromFoldableWith :: forall f a. Foldable f => (a -> a -> a) -> f (Tuple String a) -> StrMap a
fromFoldableWith f l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> runFn4 _lookupST v (f v) k s >>= SM.poke s k)
  pure s)

foreign import _collect :: forall a b . (String -> a -> b) -> StrMap a -> Array b

-- | Unfolds a map into a list of key/value pairs
toUnfoldable :: forall f a. Unfoldable f => StrMap a -> f (Tuple String a)
toUnfoldable = A.toUnfoldable <<< _collect Tuple

-- | Unfolds a map into a list of key/value pairs which is guaranteed to be
-- | sorted by key
toAscUnfoldable :: forall f a. Unfoldable f => StrMap a -> f (Tuple String a)
toAscUnfoldable = A.toUnfoldable <<< A.sortWith fst <<< _collect Tuple

-- Internal
toArray :: forall a. StrMap a -> Array (Tuple String a)
toArray = _collect Tuple

-- | Get an array of the keys in a map
foreign import keys :: forall a. StrMap a -> Array String

-- | Get a list of the values in a map
values :: forall a. StrMap a -> Array a
values = _collect (\_ v -> v)

-- | Compute the union of two maps, preferring the first map in the case of
-- | duplicate keys.
union :: forall a. StrMap a -> StrMap a -> StrMap a
union m = mutate (\s -> void $ foldM SM.poke s m)

-- | Compute the union of a collection of maps
unions :: forall f a. Foldable f => f (StrMap a) -> StrMap a
unions = foldl union empty

foreign import _mapWithKey :: forall a b. Fn2 (StrMap a) (String -> a -> b) (StrMap b)

-- | Apply a function of two arguments to each key/value pair, producing a new map
mapWithKey :: forall a b. (String -> a -> b) -> StrMap a -> StrMap b
mapWithKey f m = runFn2 _mapWithKey m f

instance semigroupStrMap :: (Semigroup a) => Semigroup (StrMap a) where
  append m1 m2 = mutate (\s1 -> void $ foldM (\s2 k v2 -> SM.poke s2 k (runFn4 _lookup v2 (\v1 -> v1 <> v2) k m2)) s1 m1) m2

instance monoidStrMap :: (Semigroup a) => Monoid (StrMap a) where
  mempty = empty

-- | This module defines a type of native Javascript maps which
-- | require the keys to be strings.
-- |
-- | To maximize performance, Javascript objects are not wrapped,
-- | and some native code is used even when it's not necessary.

module Data.StrMap
  ( StrMap
  , empty
  , isEmpty
  , size
  , singleton
  , insert
  , lookup
  , toUnfoldable
  , toAscUnfoldable
  , fromFoldable
  , fromFoldableWith
  , delete
  , pop
  , member
  , alter
  , update
  , mapWithKey
  , keys
  , values
  , union
  , unions
  , isSubmap
  , fold
  , foldMap
  , foldM
  , foldMaybe
  , all
  , thawST
  , freezeST
  , runST
  , pureST
  ) where

import Prelude

import Control.Monad.Eff (Eff, runPure)
import Control.Monad.ST as ST

import Data.Array as A
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable, foldl, foldr, for_)
import Data.Function.Uncurried (Fn2, runFn2, Fn4, runFn4)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.StrMap.ST as SM
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..), fst)
import Data.Unfoldable (class Unfoldable)

-- | `StrMap a` represents a map from `String`s to values of type `a`.
foreign import data StrMap :: Type -> Type

foreign import _copyEff :: forall a b h r. a -> Eff (st :: ST.ST h | r) b

-- | Convert an immutable map into a mutable map
thawST :: forall a h r. StrMap a -> Eff (st :: ST.ST h | r) (SM.STStrMap h a)
thawST = _copyEff

-- | Convert a mutable map into an immutable map
freezeST :: forall a h r. SM.STStrMap h a -> Eff (st :: ST.ST h | r) (StrMap a)
freezeST = _copyEff

-- | Freeze a mutable map, creating an immutable map. Use this function as you would use
-- | `Prelude.runST` to freeze a mutable reference.
-- |
-- | The rank-2 type prevents the map from escaping the scope of `runST`.
foreign import runST :: forall a r. (forall h. Eff (st :: ST.ST h | r) (SM.STStrMap h a)) -> Eff r (StrMap a)

pureST :: forall a. (forall h e. Eff (st :: ST.ST h | e) (SM.STStrMap h a)) -> StrMap a
pureST f = runPure (runST f)

mutate :: forall a b. (forall h e. SM.STStrMap h a -> Eff (st :: ST.ST h | e) b) -> StrMap a -> StrMap a
mutate f m = pureST do
  s <- thawST m
  _ <- f s
  pure s

foreign import _fmapStrMap :: forall a b. Fn2 (StrMap a) (a -> b) (StrMap b)

instance functorStrMap :: Functor StrMap where
  map f m = runFn2 _fmapStrMap m f

foreign import _foldM :: forall a m z. (m -> (z -> m) -> m) -> (z -> String -> a -> m) -> m -> StrMap a -> m

-- | Fold the keys and values of a map
fold :: forall a z. (z -> String -> a -> z) -> z -> StrMap a -> z
fold = _foldM ((#))

-- | Fold the keys and values of a map, accumulating values using
-- | some `Monoid`.
foldMap :: forall a m. Monoid m => (String -> a -> m) -> StrMap a -> m
foldMap f = fold (\acc k v -> acc <> f k v) mempty

-- | Fold the keys and values of a map, accumulating values and effects in
-- | some `Monad`.
foldM :: forall a m z. Monad m => (z -> String -> a -> m z) -> z -> StrMap a -> m z
foldM f z = _foldM bind f (pure z)

instance foldableStrMap :: Foldable StrMap where
  foldl f = fold (\z _ -> f z)
  foldr f z m = foldr f z (values m)
  foldMap f = foldMap (const f)

instance traversableStrMap :: Traversable StrMap where
  traverse f ms = fold (\acc k v -> insert k <$> f v <*> acc) (pure empty) ms
  sequence = traverse id

-- Unfortunately the above are not short-circuitable (consider using purescript-machines)
-- so we need special cases:

foreign import _foldSCStrMap :: forall a z. Fn4 (StrMap a) z (z -> String -> a -> Maybe z) (forall b. b -> Maybe b -> b) z

-- | Fold the keys and values of a map.
-- |
-- | This function allows the folding function to terminate the fold early,
-- | using `Maybe`.
foldMaybe :: forall a z. (z -> String -> a -> Maybe z) -> z -> StrMap a -> z
foldMaybe f z m = runFn4 _foldSCStrMap m z f fromMaybe

-- | Test whether all key/value pairs in a `StrMap` satisfy a predicate.
foreign import all :: forall a. (String -> a -> Boolean) -> StrMap a -> Boolean

instance eqStrMap :: Eq a => Eq (StrMap a) where
  eq m1 m2 = (isSubmap m1 m2) && (isSubmap m2 m1)

instance eq1StrMap :: Eq1 StrMap where
  eq1 = eq

-- Internal use
toAscArray :: forall v. StrMap v -> Array (Tuple String v)
toAscArray = toAscUnfoldable

instance ordStrMap :: Ord a => Ord (StrMap a) where
  compare m1 m2 = compare (toAscArray m1) (toAscArray m2)

instance showStrMap :: Show a => Show (StrMap a) where
  show m = "(fromFoldable " <> show (toArray m) <> ")"

-- | An empty map
foreign import empty :: forall a. StrMap a

-- | Test whether one map contains all of the keys and values contained in another map
isSubmap :: forall a. Eq a => StrMap a -> StrMap a -> Boolean
isSubmap m1 m2 = all f m1 where
  f k v = runFn4 _lookup false ((==) v) k m2

-- | Test whether a map is empty
isEmpty :: forall a. StrMap a -> Boolean
isEmpty = all (\_ _ -> false)

-- | Calculate the number of key/value pairs in a map
foreign import size :: forall a. StrMap a -> Int

-- | Create a map with one key/value pair
singleton :: forall a. String -> a -> StrMap a
singleton k v = pureST do
  s <- SM.new
  _ <- SM.poke s k v
  pure s

foreign import _lookup :: forall a z. Fn4 z (a -> z) String (StrMap a) z

-- | Lookup the value for a key in a map
lookup :: forall a. String -> StrMap a -> Maybe a
lookup = runFn4 _lookup Nothing Just

-- | Test whether a `String` appears as a key in a map
member :: forall a. String -> StrMap a -> Boolean
member = runFn4 _lookup false (const true)

-- | Insert or replace a key/value pair in a map
insert :: forall a. String -> a -> StrMap a -> StrMap a
insert k v = mutate (\s -> void $ SM.poke s k v)

foreign import _unsafeDeleteStrMap :: forall a. Fn2 (StrMap a) String (StrMap a)

-- | Delete a key and value from a map
delete :: forall a. String -> StrMap a -> StrMap a
delete k = mutate (\s -> void $ SM.delete s k)

-- | Delete a key and value from a map, returning the value
-- | as well as the subsequent map
pop :: forall a. String -> StrMap a -> Maybe (Tuple a (StrMap a))
pop k m = lookup k m <#> \a -> Tuple a (delete k m)

-- | Insert, remove or update a value for a key in a map
alter :: forall a. (Maybe a -> Maybe a) -> String -> StrMap a -> StrMap a
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Remove or update a value for a key in a map
update :: forall a. (a -> Maybe a) -> String -> StrMap a -> StrMap a
update f k m = alter (maybe Nothing f) k m

-- | Create a map from a foldable collection of key/value pairs
fromFoldable :: forall f a. Foldable f => f (Tuple String a) -> StrMap a
fromFoldable l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> SM.poke s k v)
  pure s)

foreign import _lookupST :: forall a h r z. Fn4 z (a -> z) String (SM.STStrMap h a) (Eff (st :: ST.ST h | r) z)

-- | Create a map from a foldable collection of key/value pairs, using the
-- | specified function to combine values for duplicate keys.
fromFoldableWith :: forall f a. Foldable f => (a -> a -> a) -> f (Tuple String a) -> StrMap a
fromFoldableWith f l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> runFn4 _lookupST v (f v) k s >>= SM.poke s k)
  pure s)

foreign import _collect :: forall a b . (String -> a -> b) -> StrMap a -> Array b

-- | Unfolds a map into a list of key/value pairs
toUnfoldable :: forall f a. Unfoldable f => StrMap a -> f (Tuple String a)
toUnfoldable = A.toUnfoldable <<< _collect Tuple

-- | Unfolds a map into a list of key/value pairs which is guaranteed to be
-- | sorted by key
toAscUnfoldable :: forall f a. Unfoldable f => StrMap a -> f (Tuple String a)
toAscUnfoldable = A.toUnfoldable <<< A.sortWith fst <<< _collect Tuple

-- Internal
toArray :: forall a. StrMap a -> Array (Tuple String a)
toArray = _collect Tuple

-- | Get an array of the keys in a map
foreign import keys :: forall a. StrMap a -> Array String

-- | Get a list of the values in a map
values :: forall a. StrMap a -> Array a
values = _collect (\_ v -> v)

-- | Compute the union of two maps, preferring the first map in the case of
-- | duplicate keys.
union :: forall a. StrMap a -> StrMap a -> StrMap a
union m = mutate (\s -> void $ foldM SM.poke s m)

-- | Compute the union of a collection of maps
unions :: forall f a. Foldable f => f (StrMap a) -> StrMap a
unions = foldl union empty

foreign import _mapWithKey :: forall a b. Fn2 (StrMap a) (String -> a -> b) (StrMap b)

-- | Apply a function of two arguments to each key/value pair, producing a new map
mapWithKey :: forall a b. (String -> a -> b) -> StrMap a -> StrMap b
mapWithKey f m = runFn2 _mapWithKey m f

instance semigroupStrMap :: (Semigroup a) => Semigroup (StrMap a) where
  append m1 m2 = mutate (\s1 -> void $ foldM (\s2 k v2 -> SM.poke s2 k (runFn4 _lookup v2 (\v1 -> v1 <> v2) k m2)) s1 m1) m2

instance monoidStrMap :: (Semigroup a) => Monoid (StrMap a) where
  mempty = empty


Update comments

Update comments

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , RedoxContext
  , RedoxSpec
  , withStore
  , connect'
  , connectEq'
  , connect
  , connectEq
  , withDispatch
  , dispatch
  , asReactClass
  , overRedoxSpec
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Fiber)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import Data.Traversable (traverse_)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, childrenToArray, createClass, createElement, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Fiber (redox :: RedoxStore reff | eff) Unit)

-- | Shallowly compare two objects.  If the first argument is true it skips
-- | comparing the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

newtype RedoxContext state dsl reff eff = RedoxContext
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function available through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.  It serves the same purpose
-- | as
-- | [Provider](https://github.com/reactjs/react-redux/blob/master/docs/api.md#provider-store)
-- | class in `react-redux`.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> Eff eff (ReactClass props)
withStore store dispatch_ cls =
  pure $ withContext cls { redox: RedoxContext { store, dispatch: dispatch_ store } }

newtype ConnectState state = ConnectState { state :: state, sid :: Maybe SubscriptionId }

derive instance newtypeConnectState :: Newtype (ConnectState state) _

-- | internal `_connect` implementation
_connect
  :: forall state state' dsl props props' reff eff
  -- | compare state in `componentShouldUpdate`
   . (state' -> state' -> Boolean)
  -- | compare props in `componentShouldUpdate`
  -> (props' -> props' -> Boolean)
  -- | lens which gets the internal state (`state'`) from the store's state
  -- | (`state`)
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect eqs eqp _lns _iso cls = (R.spec' getInitialState rndr)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = didMount
    , componentWillUnmount = willUnmount
    , shouldComponentUpdate = shouldUpdate
    }
  where
    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cwc :: ReactClass props
    cwc = accessContext cls

    cp :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    cp = Proxy

    readRC this = _.redox <$> readContext cp this

    update this state = do
      st <- readState this
      isMounted <- readIsMounted this
      when isMounted do
        void $ writeState this $ over ConnectState (_ { state = view _lns state }) st

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to `readRC`
      RedoxContext ctx <- unsafeCoerceEff $ readRC this
      state <- view _lns <$> Redox.getState ctx.store
      pure (ConnectState { state, sid: Nothing })

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    didMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ readRC this
      ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      state' <- view _lns <$> Redox.getState store
      _ <- if state `eqs` state'
        then writeState this (ConnectState { sid: Just sid, state })
        else writeState this (ConnectState { sid: Just sid, state: state' })
      pure unit

    willUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ readRC this
      ConnectState { sid } <- R.readState this
      traverse_ (Redox.unsubscribe ctx.store) sid

    -- | If `Eq state'` and `Eq props'` are not tight enought you might end up
    -- | with an infitinte loop of actions.  If you see a stack overflow error
    -- | this the usal the cause.  You can use `Data.Record.equal` or
    -- | `Unsafe.Reference.unsafeRefEq` (i.e. JavaScripts `===`) or
    -- | `React.Redox.unsafeShallowEqual` functions.
    shouldUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not (st.state `eqs` nSt.state) || not (pr `eqp` nPr)

    rndr this = do
      props' <- R.getProps this
      children <- R.getChildren this
      RedoxContext ctx <- unsafeCoerceEff $ readRC this
      ConnectState { state } <- R.readState this
      pure $ R.createElement cwc (_iso ctx.dispatch state props') children

-- | Newtype wrapper around `ReactSpec`.  Use  `overRedoxSpec` to change the
-- | underlying spec and `asReactClass` to create a react class.
newtype RedoxSpec props state eff = RedoxSpec (ReactSpec props state eff)

overRedoxSpec
  :: forall props state eff
   . (ReactSpec props state eff ->  ReactSpec props state eff)
  -> RedoxSpec props state eff
  -> RedoxSpec props state eff
overRedoxSpec f (RedoxSpec spec) = RedoxSpec <<< f $ spec

asReactClass :: forall props state eff. RedoxSpec props state eff -> ReactClass props
asReactClass (RedoxSpec spec) = accessContext <<< createClass $ spec

-- | This function makes the redox store and dispatch function available
-- | through context.  The first argument is a lens that identifies the part
-- | of redox store's state that you want to subscribe for.  The view on this
-- | lens will be checked for changes, so if you want to optimise your code,
-- | return as 'tight' lens as possible.
-- |
-- | Use `asReactClass` function to create react class from `RedoxSpec` that
-- | this function returns and `overRedoxSpec` to possibly change the spec, for
-- | example by changing the `shouldComponentUpdate` react life cycle method.
-- |
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
-- |
-- | Not the `Eq` type classes must be resolved when you apply this fuction.
-- | Otherwise you will endup with
-- | [re-mounts](https://github.com/purescript-contrib/purescript-react/issues/105).
-- | This can lead to components loosing focus (in case of `input` elements).
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> (state' -> state' -> Boolean)
  -> (props' -> props' -> Boolean)
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ eqs eqp _lns _iso cls = RedoxSpec $ _connect eqs eqp _lns _iso cls

connectEq'
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => Eq props'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectEq' p = connect' p (==) (==)

-- | Like `connect'` but for `ReactClass`-es.
connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> (state' -> state' -> Boolean)
  -> (props' -> props' -> Boolean)
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p eqs eqp _lns _iso cls = asReactClass $ connect' p eqs eqp _lns _iso cls

connectEq
  :: forall state state' dsl props props' reff eff'
   . Eq state'
  => Eq props'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connectEq p = connect p (==) (==)

-- | If you just want to wrap your actions with a dispatch function use this
-- | function.  Unlike `connect'` (and `connect`) it does not wrap your
-- | component inside another component.
withDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -- todo: childrenToArray
  -> createElement cls (fn disp props') (childrenToArray (unsafeCoerce props').children)

-- | The component must be wrapped with `accessContext` to use this function.
-- | `connect` and `asReactClass` do that for you.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Fiber (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit)
dispatch this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , RedoxContext
  , RedoxSpec
  , withStore
  , connect'
  , connectEq'
  , connect
  , connectEq
  , withDispatch
  , dispatch
  , asReactClass
  , overRedoxSpec
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Fiber)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import Data.Traversable (traverse_)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, childrenToArray, createClass, createElement, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Fiber (redox :: RedoxStore reff | eff) Unit)

-- | Shallowly compare two objects.  If the first argument is true it skips
-- | comparing the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

newtype RedoxContext state dsl reff eff = RedoxContext
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function available through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> Eff eff (ReactClass props)
withStore store dispatch_ cls =
  pure $ withContext cls { redox: RedoxContext { store, dispatch: dispatch_ store } }

newtype ConnectState state = ConnectState { state :: state, sid :: Maybe SubscriptionId }

derive instance newtypeConnectState :: Newtype (ConnectState state) _

-- | internal `_connect` implementation
_connect
  :: forall state state' dsl props props' reff eff
  -- | compare state in `componentShouldUpdate`
   . (state' -> state' -> Boolean)
  -- | compare props in `componentShouldUpdate`
  -> (props' -> props' -> Boolean)
  -- | lens which gets the internal state (`state'`) from the store's state
  -- | (`state`)
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect eqs eqp _lns _iso cls = (R.spec' getInitialState rndr)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = didMount
    , componentWillUnmount = willUnmount
    , shouldComponentUpdate = shouldUpdate
    }
  where
    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cwc :: ReactClass props
    cwc = accessContext cls

    cp :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    cp = Proxy

    readRC this = _.redox <$> readContext cp this

    update this state = do
      st <- readState this
      isMounted <- readIsMounted this
      when isMounted do
        void $ writeState this $ over ConnectState (_ { state = view _lns state }) st

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to `readRC`
      RedoxContext ctx <- unsafeCoerceEff $ readRC this
      state <- view _lns <$> Redox.getState ctx.store
      pure (ConnectState { state, sid: Nothing })

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    didMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ readRC this
      ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      state' <- view _lns <$> Redox.getState store
      _ <- if state `eqs` state'
        then writeState this (ConnectState { sid: Just sid, state })
        else writeState this (ConnectState { sid: Just sid, state: state' })
      pure unit

    willUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ readRC this
      ConnectState { sid } <- R.readState this
      traverse_ (Redox.unsubscribe ctx.store) sid

    -- | If `Eq state'` and `Eq props'` are not tight enought you might end up
    -- | with an infitinte loop of actions.  If you see a stack overflow error
    -- | this the usal the cause.  You can use `Data.Record.equal` or
    -- | `Unsafe.Reference.unsafeRefEq` (i.e. JavaScripts `===`) or
    -- | `React.Redox.unsafeShallowEqual` functions.
    shouldUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not (st.state `eqs` nSt.state) || not (pr `eqp` nPr)

    rndr this = do
      props' <- R.getProps this
      children <- R.getChildren this
      RedoxContext ctx <- unsafeCoerceEff $ readRC this
      ConnectState { state } <- R.readState this
      pure $ R.createElement cwc (_iso ctx.dispatch state props') children

-- | Newtype wrapper around `ReactSpec`.  Use  `overRedoxSpec` to change the
-- | underlying spec and `asReactClass` to create a react class.
newtype RedoxSpec props state eff = RedoxSpec (ReactSpec props state eff)

overRedoxSpec
  :: forall props state eff
   . (ReactSpec props state eff ->  ReactSpec props state eff)
  -> RedoxSpec props state eff
  -> RedoxSpec props state eff
overRedoxSpec f (RedoxSpec spec) = RedoxSpec <<< f $ spec

asReactClass :: forall props state eff. RedoxSpec props state eff -> ReactClass props
asReactClass (RedoxSpec spec) = accessContext <<< createClass $ spec

-- | This function makes the redox store and dispatch function available
-- | through context.  The first argument is a lens that identifies the part
-- | of redox store's state that you want to subscribe for.  The view on this
-- | lens will be checked for changes, so if you want to optimise your code,
-- | return as 'tight' lens as possible.
-- |
-- | Use `asReactClass` function to create react class from `RedoxSpec` that
-- | this function returns and `overRedoxSpec` to possibly change the spec, for
-- | example by changing the `shouldComponentUpdate` react life cycle method.
-- |
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
-- |
-- | Not the `Eq` type classes must be resolved when you apply this fuction.
-- | Otherwise you will endup with
-- | [re-mounts](https://github.com/purescript-contrib/purescript-react/issues/105).
-- | This can lead to components loosing focus (in case of `input` elements).
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> (state' -> state' -> Boolean)
  -> (props' -> props' -> Boolean)
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ eqs eqp _lns _iso cls = RedoxSpec $ _connect eqs eqp _lns _iso cls

connectEq'
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => Eq props'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectEq' p = connect' p (==) (==)

-- | Like `connect'` but for `ReactClass`-es.
connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> (state' -> state' -> Boolean)
  -> (props' -> props' -> Boolean)
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p eqs eqp _lns _iso cls = asReactClass $ connect' p eqs eqp _lns _iso cls

connectEq
  :: forall state state' dsl props props' reff eff'
   . Eq state'
  => Eq props'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connectEq p = connect p (==) (==)

-- | If you just want to wrap your actions with a dispatch function use this
-- | function.  Unlike `connect'` (and `connect`) it does not wrap your
-- | component inside another component.
withDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -- todo: childrenToArray
  -> createElement cls (fn disp props') (childrenToArray (unsafeCoerce props').children)

-- | The component must be wrapped with `accessContext` to use this function.
-- | `connect` and `asReactClass` do that for you.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Fiber (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit)
dispatch this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl