Add lens for actions

Add lens for actions

module React.Redux
  ( ReduxReactClass
  , Effects
  , REDUX
  , Reducer
  , Enhancer
  , Enhancer_
  , Store
  , Spec
  , Render
  , GetInitialState
  , ComponentWillMount
  , ComponentDidMount
  , ComponentWillReceiveProps
  , ShouldComponentUpdate
  , ComponentWillUpdate
  , ComponentDidUpdate
  , ComponentWillUnmount
  , createClass
  , createProviderElement
  , createElement
  , createStore
  , createStore'
  , reducerOptic
  , spec
  , spec'
  ) where

import Prelude (Unit, (<<<), (>>=), (<$), const, pure, id, unit)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)

import Data.Either (Either, either)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Lens (Getter', Lens', Prism', matching, set, view)

import Unsafe.Coerce (unsafeCoerce)

import React as React

type Reducer action state = action -> state -> state

type Enhancer eff action state = (Reducer action state -> state -> Eff (Effects eff) (Store action state)) -> (Reducer action state -> state -> Eff (Effects eff) (Store action state))

type Enhancer_ eff action state = (Fn2 (Reducer action state) state (Eff (Effects eff) (Store action state))) -> (Fn2 (Reducer action state) state (Eff (Effects eff) (Store action state)))

type Effects eff = (redux :: REDUX | eff)

type Render props state eff f action = (f action -> f action) -> React.Render props state eff

type GetInitialState props state eff f action = (f action -> f action) -> React.GetInitialState props state eff

type ComponentWillMount props state eff f action = (f action -> f action) -> React.ComponentWillMount props state eff

type ComponentDidMount props state eff f action = (f action -> f action) -> React.ComponentDidMount props state eff

type ComponentWillReceiveProps props state eff f action = (f action -> f action) -> React.ComponentWillReceiveProps props state eff

type ShouldComponentUpdate props state eff f action = (f action -> f action) -> React.ShouldComponentUpdate props state eff

type ComponentWillUpdate props state eff f action = (f action -> f action) -> React.ComponentWillUpdate props state eff

type ComponentDidUpdate props state eff f action = (f action -> f action) -> React.ComponentDidUpdate props state eff

type ComponentWillUnmount props state eff f action = (f action -> f action) -> React.ComponentWillUnmount props state eff

type Spec props state eff f action =
  { render :: Render props state eff f action
  , displayName :: String
  , getInitialState :: GetInitialState props state eff f action
  , componentWillMount :: ComponentWillMount props state eff f action
  , componentDidMount :: ComponentDidMount props state eff f action
  , componentWillReceiveProps :: ComponentWillReceiveProps props state eff f action
  , shouldComponentUpdate :: ShouldComponentUpdate props state eff f action
  , componentWillUpdate :: ComponentWillUpdate props state eff f action
  , componentDidUpdate :: ComponentDidUpdate props state eff f action
  , componentWillUnmount :: ComponentWillUnmount props state eff f action
  }

spec ::
  forall props state eff f action.
    GetInitialState props state eff f action ->
    Render props state eff f action ->
    Spec props state eff f action
spec getInitialState render =
  { render: render
  , displayName: ""
  , getInitialState: getInitialState
  , componentWillMount: \_ _ -> pure unit
  , componentDidMount: \_ _ -> pure unit
  , componentWillReceiveProps: \_ _ _ -> pure unit
  , shouldComponentUpdate: \_ _ _ _ -> pure true
  , componentWillUpdate: \_ _ _ _ -> pure unit
  , componentDidUpdate: \_ _ _ _ -> pure unit
  , componentWillUnmount: \_ _ -> pure unit
  }

spec' :: forall props eff f action. Render props Unit eff f action -> Spec props Unit eff f action
spec' = spec (\_ _ -> pure unit)

createClass :: forall props state eff f action action' state'. MonadEff (Effects eff) f => Getter' action' action -> Getter' state' props -> Spec props state eff f action' -> ReduxReactClass state' props
createClass actionLens stateLens spec_ = connect (view stateLens) reactClass
  where
  reactClass :: React.ReactClass props
  reactClass =
    React.createClass { render: \this -> spec_.render (dispatch this) this
                      , displayName: spec_.displayName
                      , getInitialState: \this -> spec_.getInitialState (dispatch this) this
                      , componentWillMount: \this -> spec_.componentWillMount (dispatch this) this
                      , componentDidMount: \this -> spec_.componentDidMount (dispatch this) this
                      , componentWillReceiveProps: \this -> spec_.componentWillReceiveProps (dispatch this) this
                      , shouldComponentUpdate: \this -> spec_.shouldComponentUpdate (dispatch this) this
                      , componentWillUpdate: \this -> spec_.componentWillUpdate (dispatch this) this
                      , componentDidUpdate: \this -> spec_.componentDidUpdate (dispatch this) this
                      , componentWillUnmount: \this -> spec_.componentWillUnmount (dispatch this) this
                      }
    where
    dispatch :: React.ReactThis props state -> f action' -> f action'
    dispatch this action' = action' >>= \a -> a <$ liftEff (runFn2 dispatch_ this (view actionLens a))

createProviderElement :: forall props action state'. Store action state' -> ReduxReactClass state' props -> React.ReactElement
createProviderElement store reduxClass = React.createElement providerClass { store: store } [ createElement reduxClass ]

createElement :: forall props state'. ReduxReactClass state' props -> React.ReactElement
createElement reduxClass = React.createElement (unsafeCoerce reduxClass) (unsafeCoerce unit) []

createStore :: forall eff action state. Reducer action state -> state -> Eff (Effects eff) (Store action state)
createStore reducer state = createStore' reducer state id

createStore' :: forall eff action state. Reducer action state -> state -> Enhancer eff action state -> Eff (Effects eff) (Store action state)
createStore' reducer state enhancer = runFn3 createStore_ reducer state (mkFn2 <<< enhancer <<< runFn2)

reducerOptic :: forall state state' action action'. Lens' state state' -> Prism' action action' -> Reducer action' state' -> Reducer action state
reducerOptic lens prism k action state = either (const state) (\a -> set lens (k a state') state) action'
  where
  state' :: state'
  state' = view lens state

  action' :: Either action action'
  action' = matching prism action

foreign import data REDUX :: !

foreign import data Store :: * -> * -> *

foreign import data ReduxReactClass :: * -> * -> *

foreign import connect :: forall state' props. (state' -> props) -> React.ReactClass props -> ReduxReactClass state' props

foreign import dispatch_ :: forall eff props action state. Fn2 (React.ReactThis props state) action (Eff (Effects eff) action)

foreign import providerClass :: forall action state'. React.ReactClass { store :: Store action state' }

foreign import createStore_ :: forall eff action state. Fn3 (Reducer action state) state (Enhancer_ eff action state) (Eff (Effects eff) (Store action state))

module React.Redux
  ( ReduxReactClass
  , Effects
  , REDUX
  , Reducer
  , Enhancer
  , Enhancer_
  , Store
  , createClass
  , createProviderElement
  , createElement
  , createStore
  , createStore'
  , reducerOptic

  , Spec
  , Render
  , GetInitialState
  , ComponentWillMount
  , ComponentDidMount
  , ComponentWillReceiveProps
  , ShouldComponentUpdate
  , ComponentWillUpdate
  , ComponentDidUpdate
  , ComponentWillUnmount
  , spec
  , spec'
  ) where

import Prelude (Unit, (<<<), (>>=), const, pure, id, unit)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)

import Data.Either (Either, either)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Lens (Getter', Lens', Prism', matching, set, view)

import Unsafe.Coerce (unsafeCoerce)

import React as React

type Reducer action state = action -> state -> state

type Enhancer eff action state = (Reducer action state -> state -> Eff (Effects eff) (Store action state)) -> (Reducer action state -> state -> Eff (Effects eff) (Store action state))

type Enhancer_ eff action state = (Fn2 (Reducer action state) state (Eff (Effects eff) (Store action state))) -> (Fn2 (Reducer action state) state (Eff (Effects eff) (Store action state)))

type Effects eff = (redux :: REDUX | eff)

type Render props state eff f action = (f action -> f action) -> React.Render props state eff

type GetInitialState props state eff f action = (f action -> f action) -> React.GetInitialState props state eff

type ComponentWillMount props state eff f action = (f action -> f action) -> React.ComponentWillMount props state eff

type ComponentDidMount props state eff f action = (f action -> f action) -> React.ComponentDidMount props state eff

type ComponentWillReceiveProps props state eff f action = (f action -> f action) -> React.ComponentWillReceiveProps props state eff

type ShouldComponentUpdate props state eff f action = (f action -> f action) -> React.ShouldComponentUpdate props state eff

type ComponentWillUpdate props state eff f action = (f action -> f action) -> React.ComponentWillUpdate props state eff

type ComponentDidUpdate props state eff f action = (f action -> f action) -> React.ComponentDidUpdate props state eff

type ComponentWillUnmount props state eff f action = (f action -> f action) -> React.ComponentWillUnmount props state eff

type Spec props state eff f action =
  { render :: Render props state eff f action
  , displayName :: String
  , getInitialState :: GetInitialState props state eff f action
  , componentWillMount :: ComponentWillMount props state eff f action
  , componentDidMount :: ComponentDidMount props state eff f action
  , componentWillReceiveProps :: ComponentWillReceiveProps props state eff f action
  , shouldComponentUpdate :: ShouldComponentUpdate props state eff f action
  , componentWillUpdate :: ComponentWillUpdate props state eff f action
  , componentDidUpdate :: ComponentDidUpdate props state eff f action
  , componentWillUnmount :: ComponentWillUnmount props state eff f action
  }

spec ::
  forall props state eff f action.
    GetInitialState props state eff f action ->
    Render props state eff f action ->
    Spec props state eff f action
spec getInitialState render =
  { render: render
  , displayName: ""
  , getInitialState: getInitialState
  , componentWillMount: \_ _ -> pure unit
  , componentDidMount: \_ _ -> pure unit
  , componentWillReceiveProps: \_ _ _ -> pure unit
  , shouldComponentUpdate: \_ _ _ _ -> pure true
  , componentWillUpdate: \_ _ _ _ -> pure unit
  , componentDidUpdate: \_ _ _ _ -> pure unit
  , componentWillUnmount: \_ _ -> pure unit
  }

spec' :: forall props eff f action. Render props Unit eff f action -> Spec props Unit eff f action
spec' = spec (\_ _ -> pure unit)

createClass :: forall props state eff f action state'. MonadEff (Effects eff) f => Getter' state' props -> Spec props state eff f action -> ReduxReactClass state' props
createClass lens spec_ = connect (view lens) reactClass
  where
  reactClass :: React.ReactClass props
  reactClass =
    React.createClass { render: \this -> spec_.render (dispatch this) this
                      , displayName: spec_.displayName
                      , getInitialState: \this -> spec_.getInitialState (dispatch this) this
                      , componentWillMount: \this -> spec_.componentWillMount (dispatch this) this
                      , componentDidMount: \this -> spec_.componentDidMount (dispatch this) this
                      , componentWillReceiveProps: \this -> spec_.componentWillReceiveProps (dispatch this) this
                      , shouldComponentUpdate: \this -> spec_.shouldComponentUpdate (dispatch this) this
                      , componentWillUpdate: \this -> spec_.componentWillUpdate (dispatch this) this
                      , componentDidUpdate: \this -> spec_.componentDidUpdate (dispatch this) this
                      , componentWillUnmount: \this -> spec_.componentWillUnmount (dispatch this) this
                      }
    where
    dispatch :: React.ReactThis props state -> f action -> f action
    dispatch this action = action >>= liftEff <<< runFn2 dispatch_ this

createProviderElement :: forall props action state'. Store action state' -> ReduxReactClass state' props -> React.ReactElement
createProviderElement store reduxClass = React.createElement providerClass { store: store } [ createElement reduxClass ]

createElement :: forall props state'. ReduxReactClass state' props -> React.ReactElement
createElement reduxClass = React.createElement (unsafeCoerce reduxClass) (unsafeCoerce unit) []

createStore :: forall eff action state. Reducer action state -> state -> Eff (Effects eff) (Store action state)
createStore reducer state = createStore' reducer state id

createStore' :: forall eff action state. Reducer action state -> state -> Enhancer eff action state -> Eff (Effects eff) (Store action state)
createStore' reducer state enhancer = runFn3 createStore_ reducer state (mkFn2 <<< enhancer <<< runFn2)

reducerOptic :: forall state state' action action'. Lens' state state' -> Prism' action action' -> Reducer action' state' -> Reducer action state
reducerOptic lens prism k action state = either (const state) (\a -> set lens (k a state') state) action'
  where
  state' :: state'
  state' = view lens state

  action' :: Either action action'
  action' = matching prism action

foreign import data REDUX :: !

foreign import data Store :: * -> * -> *

foreign import data ReduxReactClass :: * -> * -> *

foreign import connect :: forall state' props. (state' -> props) -> React.ReactClass props -> ReduxReactClass state' props

foreign import dispatch_ :: forall eff props action state. Fn2 (React.ReactThis props state) action (Eff (Effects eff) action)

foreign import providerClass :: forall action state'. React.ReactClass { store :: Store action state' }

foreign import createStore_ :: forall eff action state. Fn3 (Reducer action state) state (Enhancer_ eff action state) (Eff (Effects eff) (Store action state))


Fix split docs, fixes #30

Fix split docs, fixes #30

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( charAt
  , charCodeAt
  , fromCharArray
  , fromChar
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , count
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , split
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude
import Data.Char
import Data.Maybe (Maybe(..), isJust)
import Data.Monoid (Monoid)
import qualified Data.String.Unsafe as U

-- | Returns the character at the given index, if the index is within bounds.
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt :: (forall a. a -> Maybe a)
                       -> (forall a. Maybe a)
                       -> Int
                       -> String
                       -> Maybe Char

-- | Returns a string of length `1` containing the given character.
fromChar :: Char -> String
fromChar = toString

-- | Returns a string of length `1` containing the given character.
-- | Same as `fromChar`.
singleton :: Char -> String
singleton = fromChar

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

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

toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar :: (forall a. a -> Maybe a)
                       -> (forall a. Maybe a)
                       -> String
                       -> Maybe Char

-- | Returns `true` if the given string is empty.
null :: String -> Boolean
null s = length s == zero

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate:
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripPrefix "http:" "http://purescript.org" == Just "//purescript.org"`
-- | * `stripPrefix "http:" "https://purescript.org" == Nothing`
stripPrefix :: String -> String -> Maybe String
stripPrefix prefix str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefix) str
    _      -> Nothing

-- | Converts an array of characters into a string.
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the first string exists in the second string.
contains :: String -> String -> Boolean
contains x s = isJust (indexOf x s)

-- | Returns the index of the first occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
indexOf :: String -> String -> Maybe Int
indexOf = _indexOf Just Nothing

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

-- | Returns the index of the first occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
indexOf' :: String -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf' :: (forall a. a -> Maybe a)
                         -> (forall a. Maybe a)
                         -> String
                         -> Int
                         -> String
                         -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
lastIndexOf :: String -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

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

-- | Returns the index of the last occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
lastIndexOf' :: String -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf' :: (forall a. a -> Maybe a)
                             -> (forall a. Maybe a)
                             -> String
                             -> Int
                             -> String
                             -> Maybe Int

-- | Returns the number of characters the string is composed of.
foreign import length :: String -> Int

-- | Locale-aware sort order comparison.
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare :: Ordering
                              -> Ordering
                              -> Ordering
                              -> String
                              -> String
                              -> Ordering

-- | Replaces the first occurence of the first argument with the second argument.
foreign import replace :: String -> String -> String -> String

-- | Returns the first `n` characters of the string.
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- | * `split " " "hello world" == ["hello", "world"]`
foreign import split :: String -> String -> Array String

-- | Converts the string into an array of characters.
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
foreign import joinWith :: String -> Array String -> String

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( charAt
  , charCodeAt
  , fromCharArray
  , fromChar
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , count
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , split
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude
import Data.Char
import Data.Maybe (Maybe(..), isJust)
import Data.Monoid (Monoid)
import qualified Data.String.Unsafe as U

-- | Returns the character at the given index, if the index is within bounds.
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt :: (forall a. a -> Maybe a)
                       -> (forall a. Maybe a)
                       -> Int
                       -> String
                       -> Maybe Char

-- | Returns a string of length `1` containing the given character.
fromChar :: Char -> String
fromChar = toString

-- | Returns a string of length `1` containing the given character.
-- | Same as `fromChar`.
singleton :: Char -> String
singleton = fromChar

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

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

toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar :: (forall a. a -> Maybe a)
                       -> (forall a. Maybe a)
                       -> String
                       -> Maybe Char

-- | Returns `true` if the given string is empty.
null :: String -> Boolean
null s = length s == zero

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate:
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripPrefix "http:" "http://purescript.org" == Just "//purescript.org"`
-- | * `stripPrefix "http:" "https://purescript.org" == Nothing`
stripPrefix :: String -> String -> Maybe String
stripPrefix prefix str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefix) str
    _      -> Nothing

-- | Converts an array of characters into a string.
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the first string exists in the second string.
contains :: String -> String -> Boolean
contains x s = isJust (indexOf x s)

-- | Returns the index of the first occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
indexOf :: String -> String -> Maybe Int
indexOf = _indexOf Just Nothing

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

-- | Returns the index of the first occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
indexOf' :: String -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf' :: (forall a. a -> Maybe a)
                         -> (forall a. Maybe a)
                         -> String
                         -> Int
                         -> String
                         -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
lastIndexOf :: String -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

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

-- | Returns the index of the last occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
lastIndexOf' :: String -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf' :: (forall a. a -> Maybe a)
                             -> (forall a. Maybe a)
                             -> String
                             -> Int
                             -> String
                             -> Maybe Int

-- | Returns the number of characters the string is composed of.
foreign import length :: String -> Int

-- | Locale-aware sort order comparison.
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare :: Ordering
                              -> Ordering
                              -> Ordering
                              -> String
                              -> String
                              -> Ordering

-- | Replaces the first occurence of the first argument with the second argument.
foreign import replace :: String -> String -> String -> String

-- | Returns the first `n` characters of the string.
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the first string separated along occurences
-- | of the second string.
foreign import split :: String -> String -> Array String

-- | Converts the string into an array of characters.
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
foreign import joinWith :: String -> Array String -> String


update default text

update default text

module DefaultText where

defaultSrc = """

app34 :: (Vec 3 Float -> Vec 3 Float) -> Vec 4 Float -> Vec 4 Float
app34 f q = let t = f (q%xyz) in V4 (t%x) (t%y) (t%z) (q%w)

p1 = app34 $ \t -> (V3 0.5 0.5 0.5 + cos( (t + V3 0.0 0.1 0.2) *! 6.28318) *! 0.5)

f x = (x + sin x + sin (1.1 * x)) `mod` 4 * 2

makeFrame (time :: Float)
          (projmat :: Mat 4 4 Float)
          (vertexstream :: Stream (Primitive Triangle (Vec 4 Float)))

    = imageFrame (emptyDepthImage 1000, emptyColorImage navy)
  `overlay`
      vertexstream
    & mapPrimitives (\x -> ((scale 0.5 . (projmat *.)) x, x))
    & rasterizePrimitives (TriangleCtx CullNone PolygonFill NoOffset LastVertex) Smooth
    & filterFragments (\v -> (v%y * v%y + v%x * v%x + v%z * v%z) > 1.5)
    & mapFragments (\x -> p1 (rotMatrixZ time *. rotMatrixY time *. (p1 (rotMatrixX time *. rotMatrixY time *. x) *! ((1 + 0.5 * sin time)))) *! f time)
    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))

main = renderFrame $
   makeFrame (Uniform "Time")
             (Uniform "MVP")
             (fetch_ "stream4" (Attribute "position4"))

"""

module DefaultText where

defaultSrc = """

f x = (x + sin x + sin (1.1 * x)) `mod` 4.0 * 2

makeFrame (time :: Float)
          (projmat :: Mat 4 4 Float)
          (vertexstream :: VertexStream Triangle (Vec 4 Float))

    = imageFrame (emptyDepthImage 1000, emptyColorImage navy)
  `overlay`
      vertexstream
    & transformVertices (scale 0.5 . (projmat *.))
    & rasterize (TriangleCtx CullNone PolygonFill NoOffset LastVertex)
    & filterFragmentStream PassAll
    & transformFragmentsRastDepth (\x -> (rotMatrixZ time *. rotMatrixY time *. x) *! f time)
    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))

main = renderFrame $
   makeFrame (Uniform "Time")
             (Uniform "MVP")
             (Fetch "stream4" (Attribute "position4"))

"""


code style

code style

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Free (Free)
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Data.Lens (Lens', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox (ReadRedox, SubscribeRedox, ReadWriteSubscribeRedox, Store, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl eff = Free dsl (state -> state) -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble 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 eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

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

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

_connect
  :: forall state state' dsl props props' eff
   . (ReactThis props' (ConnectState state')
      -> Eff (context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff) (RedoxContext state dsl eff))
  -> Lens' state state'
  -> ((DispatchFn state dsl eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = R.transformState this (_ { state = view _lns state })

    getInitialState this = do
      ctx <- addReactDisallowedEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- addReactEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      ctx <- addReactReadOnlyEff $ ctxEff this
      msid <- (R.readState this) >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    renderFn this = do
      props' <- R.getProps this
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- unsafeCoerceEff $ R.readState this >>= pure <<< _.state
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') []

    addReactEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadWrite, refs :: R.ReactRefs (() :: # Effect) | e ) a
    addReactEff = unsafeCoerceEff

    addReactDisallowedEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.Disallowed, refs :: R.ReactRefs R.Disallowed | e ) a
    addReactDisallowedEff = unsafeCoerceEff

    addReactReadOnlyEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadOnly, refs :: R.ReactRefs R.ReadOnly | e) a
    addReactReadOnlyEff = unsafeCoerceEff

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | 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)
-- | ```
connect'
  :: forall state state' dsl props props' eff
   . Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = readContext (Proxy :: Proxy (RedoxContext state dsl eff)) this

connect
  :: forall state state' dsl props props' eff'
   . Lens' state state'
  -> (DispatchFn state dsl eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect _lns _iso cls = accessContext $ R.createClass $ connect' _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' eff
   . Store state
  -> DispatchFn state dsl eff
  -> Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl props state eff
   . ReactThis props state
  -> Free dsl (state -> state)
  -> Eff (ReadWriteSubscribeRedox (context :: CONTEXT | eff)) (Canceler (ReadWriteSubscribeRedox (context :: CONTEXT | eff)))
dispatch this dsl = do
  _dispatch <- _.redox.dispatch <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (context :: CONTEXT | eff) }) ) this
  _dispatch dsl

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Free (Free)
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Data.Lens (Lens', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox (ReadRedox, SubscribeRedox, ReadWriteSubscribeRedox, Store, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl eff = Free dsl (state -> state) -> Eff (ReadWriteSubscribeRedox eff) (Canceler (ReadWriteSubscribeRedox eff))

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble 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 eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

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

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

_connect
  :: forall state state' dsl props props' eff
   . (ReactThis props' (ConnectState state')
      -> Eff (context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff) (RedoxContext state dsl eff))
  -> Lens' state state'
  -> ((DispatchFn state dsl eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = R.transformState this (_ { state = view _lns state })

    getInitialState this = do
      ctx <- addReactDisallowedEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- addReactEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      R.transformState this (_ { sid = Just sid })

    componentWillUnmount this = do
      ctx <- addReactReadOnlyEff $ ctxEff this
      msid <- (R.readState this) >>= pure <<< _.sid
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    renderFn this = do
      props' <- R.getProps this
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- unsafeCoerceEff $ R.readState this >>= pure <<< _.state
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') []

    addReactEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadWrite, refs :: R.ReactRefs (() :: # Effect) | e ) a
    addReactEff = unsafeCoerceEff

    addReactDisallowedEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.Disallowed, refs :: R.ReactRefs R.Disallowed | e ) a
    addReactDisallowedEff = unsafeCoerceEff

    addReactReadOnlyEff :: forall a e. Eff e a -> Eff ( props :: R.ReactProps, state :: R.ReactState R.ReadOnly, refs :: R.ReactRefs R.ReadOnly | e) a
    addReactReadOnlyEff = unsafeCoerceEff

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | 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)
-- | ```
connect'
  :: forall state state' dsl props props' eff
   . Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connect' _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = readContext (Proxy :: Proxy (RedoxContext state dsl eff)) this

connect
  :: forall state state' dsl props props' eff'
   . Lens' state state'
  -> (DispatchFn state dsl eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect _lns _iso cls = accessContext $ R.createClass $ connect' _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' eff
   . Store state
  -> DispatchFn state dsl eff
  -> Lens' state state'
  -> (DispatchFn state dsl eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, readRedox :: ReadRedox, subscribeRedox :: SubscribeRedox | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl props state eff
   . ReactThis props state
  -> Free dsl (state -> state)
  -> Eff (ReadWriteSubscribeRedox (context :: CONTEXT | eff)) (Canceler (ReadWriteSubscribeRedox (context :: CONTEXT | eff)))
dispatch this dsl = do
  _dispatch <- readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (context :: CONTEXT | eff) }) ) this >>= pure <<< _.redox.dispatch
  _dispatch dsl


Ensure finalizers run when top level component is disposed

module Halogen.Aff.Driver
  ( RenderSpec
  , runUI
  , module Halogen
  ) where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Fork.Class (fork)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Parallel (parSequence_)
import Data.Either (Either(..), either)
import Data.List ((:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, isJust, isNothing)
import Data.Traversable (for_, traverse_)
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Aff (Aff, killFiber, launchAff_, runAff_, try)
import Effect.Aff.AVar as AV
import Effect.Class (liftEffect)
import Effect.Console (warn)
import Effect.Exception (error, throw, throwException)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Halogen (HalogenIO)
import Halogen.Aff.Driver.Eval as Eval
import Halogen.Aff.Driver.State (DriverState(..), DriverStateRef(..), DriverStateX, LifecycleHandlers, RenderStateX, initDriverState, mapDriverState, renderStateX, renderStateX_, unDriverStateX)
import Halogen.Component (Component, ComponentSlot, ComponentSlotBox, unComponent, unComponentSlot)
import Halogen.Data.Slot as Slot
import Halogen.Query.EventSource as ES
import Halogen.Query.HalogenQ as HQ
import Halogen.Query.Input (Input)
import Halogen.Query.Input as Input

-- | `RenderSpec` allows for alternative driver implementations without the need
-- | to provide all of the driver machinery again, focusing just on the code
-- | needed to render components.
-- |
-- | The type variables are as follows:
-- | - `h` is the type of value being rendered (`Halogen.HTML.Core.HTML`, for
-- |   example).
-- | - `r` is the type for the "render state" for the driver. This is a value
-- |   that is stored for each component, that allows the driver to persist
-- |   state between each rendering of a component. This will differ entirely
-- |   for each driver. `r` accepts a number of parameters that will be
-- |   explained below.
-- |
-- | The "inner" type variables, used by `r` and the other functions are as
-- | follows:
-- | - `s` is the state type for the component.
-- | - `act` is the action type for the component
-- | - `ps` is the set of slots for addressing child components
-- | - `o` is the output message type for the component
-- |
-- | Note that none of these variables can escape `RenderSpec`'s functions. They
-- | need to be instantiated with each function call, as the same `RenderSpec`
-- | is used to deal with all components in the hierarchy.
-- |
-- | The `render` function is the main part of the spec, it accepts:
-- | - A "handler" function, for evaluating component queries. This is used to
-- |   implement event handlers in HTML-based drivers.
-- | - A "child" function for dealing with the rendering of children, returning
-- |   the render state for the child component in an existentially hidden
-- |   package. This return value would commonly be used to extract the rendered
-- |   subtree for the child to graft it in place of the child slot. The
-- |   existential package can be unwrapped with `Halogen.Aff.Driver.State.unRenderStateX`.
-- | - The `h` value to render, parameterised by the slot type for the
-- |   component's children. This slot type is what the "child" function
-- |   accepts.
-- | - The previous render state for the component. If the component has not
-- |   previously been initalized, this will be `Nothing`.
-- |
-- | The render function then returns the updated (or initial) render state for
-- | the component, which will be fed back into `render` the next time the
-- | component needs to update.
-- |
-- | The `renderChild` function's behaviour will be highly dependant on the
-- | particular driver implementing `RenderSpec`. Its purpose is to take a
-- | driver render state for a component and produce a new one that may remap
-- | the rendered value to be something more suitable for grafting during
-- | `render` of the parent. For the built-in `halogen-vdom` driver this is
-- | just `identity`. For the `virtual-dom` driver it wraps the rendered HTML
-- | in a widget, to prevent the `virtual-dom` algorithm from re-diffing
-- | values that we know are unchanged.
-- |
-- | The `removeChild` function is for drivers that need to perform some special
-- | cleanup when removing a component from the hierarchy. In the `halogen-vdom`
-- | driver this actually performs the `removeChild` from the DOM. For the
-- | `virtual-dom` driver nothing needs to happen here, so it is
-- | `const (pure unit)`.
-- |
-- | The `dispose` function is called when the top level component is disposed of
-- | via `HalogenIO`.
type RenderSpec h r =
  { render
      :: forall s act ps o
       . (Input act -> Effect Unit)
      -> (ComponentSlotBox h ps Aff act -> Effect (RenderStateX r))
      -> h (ComponentSlot h ps Aff act) act
      -> Maybe (r s act ps o)
      -> Effect (r s act ps o)
  , renderChild :: forall s act ps o. r s act ps o -> r s act ps o
  , removeChild :: forall s act ps o. r s act ps o -> Effect Unit
  , dispose :: forall s act ps o. r s act ps o -> Effect Unit
  }

runUI
  :: forall h r f i o
   . RenderSpec h r
  -> Component h f i o Aff
  -> i
  -> Aff (HalogenIO f o Aff)
runUI renderSpec component i = do
  lchs <- liftEffect newLifecycleHandlers
  fresh <- liftEffect $ Ref.new 0
  disposed <- liftEffect $ Ref.new false
  Eval.handleLifecycle lchs do
    listeners <- Ref.new M.empty
    dsx <- Ref.read =<< runComponent lchs (rootHandler listeners) i component
    unDriverStateX (\st ->
      pure
        { query: evalDriver disposed st.selfRef
        , subscribe: subscribe fresh listeners
        , dispose: dispose disposed lchs dsx listeners
        }) dsx

  where

  evalDriver
    :: forall s f' act ps i' o'
     . Ref Boolean
    -> Ref (DriverState h r s f' act ps i' o')
    -> forall a. (f' a -> Aff (Maybe a))
  evalDriver disposed ref q =
    liftEffect (Ref.read disposed) >>=
      if _
        then pure Nothing
        else Eval.evalQ render ref q

  rootHandler :: Ref (M.Map Int (AV.AVar o)) -> o -> Aff Unit
  rootHandler ref message = do
    listeners <- liftEffect $ Ref.read ref
    traverse_ fork $ map (AV.put message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o Aff Unit
    -> Aff Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.empty
    listenerId <- liftEffect do
      listenerId <- Ref.read fresh
      Ref.modify_ (_ + 1) fresh
      Ref.modify_ (M.insert listenerId inputVar) ref
      pure listenerId
    let producer = CR.producer $ either (const (Right unit)) Left <$> try (AV.take inputVar)
    void $ fork do
      CR.runProcess (CR.connect producer consumer)
      liftEffect $ Ref.modify_ (M.delete listenerId) ref
      AV.kill (error "ended") inputVar

  runComponent
    :: forall f' i' o'
     . Ref LifecycleHandlers
    -> (o' -> Aff Unit)
    -> i'
    -> Component h f' i' o' Aff
    -> Effect (Ref (DriverStateX h r f' o'))
  runComponent lchs handler j = unComponent \c -> do
    lchs' <- newLifecycleHandlers
    var <- initDriverState c j handler lchs'
    pre <- Ref.read lchs
    Ref.write { initializers: L.Nil, finalizers: pre.finalizers } lchs
    unDriverStateX (render lchs <<< _.selfRef) =<< Ref.read var
    squashChildInitializers lchs pre.initializers =<< Ref.read var
    pure var

  render
    :: forall s f' act ps i' o'
     . Ref LifecycleHandlers
    -> Ref (DriverState h r s f' act ps i' o')
    -> Effect Unit
  render lchs var = Ref.read var >>= \(DriverState ds) -> do
    shouldProcessHandlers <- isNothing <$> Ref.read ds.pendingHandlers
    when shouldProcessHandlers $ Ref.write (Just L.Nil) ds.pendingHandlers
    Ref.write Slot.empty ds.childrenOut
    Ref.write ds.children ds.childrenIn
    let
      handler :: Input act -> Aff Unit
      handler = Eval.queueOrRun ds.pendingHandlers <<< void <<< Eval.evalF render ds.selfRef
      childHandler :: act -> Aff Unit
      childHandler = Eval.queueOrRun ds.pendingQueries <<< handler <<< Input.Action
    rendering <-
      renderSpec.render
        (handleAff <<< handler)
        (renderChild lchs childHandler ds.childrenIn ds.childrenOut)
        (ds.component.render ds.state)
        ds.rendering
    children <- Ref.read ds.childrenOut
    childrenIn <- Ref.read ds.childrenIn
    Slot.foreachSlot childrenIn \(DriverStateRef childVar) -> do
      childDS <- Ref.read childVar
      renderStateX_ renderSpec.removeChild childDS
      finalize lchs childDS
    flip Ref.modify_ ds.selfRef $ mapDriverState \ds' ->
      ds' { rendering = Just rendering, children = children }
    when shouldProcessHandlers do
      flip tailRecM unit \_ -> do
        handlers <- Ref.read ds.pendingHandlers
        Ref.write (Just L.Nil) ds.pendingHandlers
        traverse_ (handleAff <<< traverse_ fork <<< L.reverse) handlers
        mmore <- Ref.read ds.pendingHandlers
        if maybe false L.null mmore
          then Ref.write Nothing ds.pendingHandlers $> Done unit
          else pure $ Loop unit

  renderChild
    :: forall ps act
     . Ref LifecycleHandlers
    -> (act -> Aff Unit)
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> ComponentSlotBox h ps Aff act
    -> Effect (RenderStateX r)
  renderChild lchs handler childrenInRef childrenOutRef =
    unComponentSlot \slot -> do
      childrenIn <- Ref.read childrenInRef
      var <- case slot.pop childrenIn of
        Just (Tuple (DriverStateRef existing) childrenIn') -> do
          Ref.write childrenIn' childrenInRef
          dsx <- Ref.read existing
          unDriverStateX (\st -> do
            flip Ref.write st.handlerRef $ maybe (pure unit) handler <<< slot.output
            handleAff $ Eval.evalM render st.selfRef (st.component.eval slot.input)) dsx
          pure existing
        Nothing ->
          case slot.input of
            HQ.Receive si _ ->
              runComponent lchs (maybe (pure unit) handler <<< slot.output) si slot.component
            _ ->
              throw "Halogen internal error: slot input was not a Receive query"
      isDuplicate <- isJust <<< slot.get <$> Ref.read childrenOutRef
      when isDuplicate
        $ warn "Halogen: Duplicate slot address was detected during rendering, unexpected results may occur"
      Ref.modify_ (slot.set $ DriverStateRef var) childrenOutRef
      Ref.read var >>= renderStateX case _ of
        Nothing -> throw "Halogen internal error: child was not initialized in renderChild"
        Just r -> pure (renderSpec.renderChild r)

  squashChildInitializers
    :: forall f' o'
     . Ref LifecycleHandlers
    -> L.List (Aff Unit)
    -> DriverStateX h r f' o'
    -> Effect Unit
  squashChildInitializers lchs preInits =
    unDriverStateX \st -> do
      let parentInitializer = Eval.evalM render st.selfRef (st.component.eval (HQ.Initialize unit))
      Ref.modify_ (\handlers ->
        { initializers: (do
            parSequence_ (L.reverse handlers.initializers)
            parentInitializer
            liftEffect do
              handlePending st.pendingQueries
              handlePending st.pendingOuts) : preInits
        , finalizers: handlers.finalizers
        }) lchs

  finalize
    :: forall f' o'
     . Ref LifecycleHandlers
    -> DriverStateX h r f' o'
    -> Effect Unit
  finalize lchs = do
    unDriverStateX \st -> do
      cleanupSubscriptionsAndForks (DriverState st)
      let f = Eval.evalM render st.selfRef (st.component.eval (HQ.Finalize unit))
      Ref.modify_ (\handlers ->
        { initializers: handlers.initializers
        , finalizers: f : handlers.finalizers
        }) lchs
      Slot.foreachSlot st.children \(DriverStateRef ref) -> do
        dsx <- Ref.read ref
        finalize lchs dsx

  dispose :: forall f' o'
     . Ref Boolean
    -> Ref LifecycleHandlers
    -> DriverStateX h r f' o'
    -> Ref (M.Map Int (AV.AVar o'))
    -> Aff Unit
  dispose disposed lchs dsx subsRef = Eval.handleLifecycle lchs do
    Ref.read disposed >>=
      if _
        then pure unit
        else do
          Ref.write true disposed
          traverse_ (launchAff_ <<< AV.kill (error "disposed")) =<< Ref.read subsRef
          finalize lchs dsx
          unDriverStateX (traverse_ renderSpec.dispose <<< _.rendering) dsx

newLifecycleHandlers :: Effect (Ref LifecycleHandlers)
newLifecycleHandlers = Ref.new { initializers: L.Nil, finalizers: L.Nil }

handlePending :: Ref (Maybe (L.List (Aff Unit))) -> Effect Unit
handlePending ref = do
  queue <- Ref.read ref
  Ref.write Nothing ref
  for_ queue (handleAff <<< traverse_ fork <<< L.reverse)

cleanupSubscriptionsAndForks
  :: forall h r s f act ps i o
   . DriverState h r s f act ps i o
  -> Effect Unit
cleanupSubscriptionsAndForks (DriverState ds) = do
  traverse_ (handleAff <<< traverse_ (fork <<< ES.finalize)) =<< Ref.read ds.subscriptions
  Ref.write Nothing ds.subscriptions
  traverse_ (handleAff <<< killFiber (error "finalized")) =<< Ref.read ds.forks
  Ref.write M.empty ds.forks

-- We could perhaps do something more intelligent now this isn't baked into
-- the virtual-dom rendering. It hasn't really been a problem so far though.
handleAff :: forall a. Aff a -> Effect Unit
handleAff = runAff_ (either throwException (const (pure unit)))

module Halogen.Aff.Driver
  ( RenderSpec
  , runUI
  , module Halogen
  ) where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Fork.Class (fork)
import Control.Monad.Rec.Class (Step(..), tailRecM)
import Control.Parallel (parSequence_)
import Data.Either (Either(..), either)
import Data.List ((:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, isJust, isNothing)
import Data.Traversable (for_, traverse_)
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Aff (Aff, killFiber, launchAff_, runAff_, try)
import Effect.Aff.AVar as AV
import Effect.Class (liftEffect)
import Effect.Console (warn)
import Effect.Exception (error, throw, throwException)
import Effect.Ref (Ref)
import Effect.Ref as Ref
import Halogen (HalogenIO)
import Halogen.Aff.Driver.Eval as Eval
import Halogen.Aff.Driver.State (DriverState(..), DriverStateRef(..), DriverStateX, LifecycleHandlers, RenderStateX, initDriverState, mapDriverState, renderStateX, renderStateX_, unDriverStateX)
import Halogen.Component (Component, ComponentSlot, ComponentSlotBox, unComponent, unComponentSlot)
import Halogen.Data.Slot as Slot
import Halogen.Query.EventSource as ES
import Halogen.Query.HalogenQ as HQ
import Halogen.Query.Input (Input)
import Halogen.Query.Input as Input

-- | `RenderSpec` allows for alternative driver implementations without the need
-- | to provide all of the driver machinery again, focusing just on the code
-- | needed to render components.
-- |
-- | The type variables are as follows:
-- | - `h` is the type of value being rendered (`Halogen.HTML.Core.HTML`, for
-- |   example).
-- | - `r` is the type for the "render state" for the driver. This is a value
-- |   that is stored for each component, that allows the driver to persist
-- |   state between each rendering of a component. This will differ entirely
-- |   for each driver. `r` accepts a number of parameters that will be
-- |   explained below.
-- |
-- | The "inner" type variables, used by `r` and the other functions are as
-- | follows:
-- | - `s` is the state type for the component.
-- | - `act` is the action type for the component
-- | - `ps` is the set of slots for addressing child components
-- | - `o` is the output message type for the component
-- |
-- | Note that none of these variables can escape `RenderSpec`'s functions. They
-- | need to be instantiated with each function call, as the same `RenderSpec`
-- | is used to deal with all components in the hierarchy.
-- |
-- | The `render` function is the main part of the spec, it accepts:
-- | - A "handler" function, for evaluating component queries. This is used to
-- |   implement event handlers in HTML-based drivers.
-- | - A "child" function for dealing with the rendering of children, returning
-- |   the render state for the child component in an existentially hidden
-- |   package. This return value would commonly be used to extract the rendered
-- |   subtree for the child to graft it in place of the child slot. The
-- |   existential package can be unwrapped with `Halogen.Aff.Driver.State.unRenderStateX`.
-- | - The `h` value to render, parameterised by the slot type for the
-- |   component's children. This slot type is what the "child" function
-- |   accepts.
-- | - The previous render state for the component. If the component has not
-- |   previously been initalized, this will be `Nothing`.
-- |
-- | The render function then returns the updated (or initial) render state for
-- | the component, which will be fed back into `render` the next time the
-- | component needs to update.
-- |
-- | The `renderChild` function's behaviour will be highly dependant on the
-- | particular driver implementing `RenderSpec`. Its purpose is to take a
-- | driver render state for a component and produce a new one that may remap
-- | the rendered value to be something more suitable for grafting during
-- | `render` of the parent. For the built-in `halogen-vdom` driver this is
-- | just `identity`. For the `virtual-dom` driver it wraps the rendered HTML
-- | in a widget, to prevent the `virtual-dom` algorithm from re-diffing
-- | values that we know are unchanged.
-- |
-- | The `removeChild` function is for drivers that need to perform some special
-- | cleanup when removing a component from the hierarchy. In the `halogen-vdom`
-- | driver this actually performs the `removeChild` from the DOM. For the
-- | `virtual-dom` driver nothing needs to happen here, so it is
-- | `const (pure unit)`.
-- |
-- | The `dispose` function is called when the top level component is disposed of
-- | via `HalogenIO`.
type RenderSpec h r =
  { render
      :: forall s act ps o
       . (Input act -> Effect Unit)
      -> (ComponentSlotBox h ps Aff act -> Effect (RenderStateX r))
      -> h (ComponentSlot h ps Aff act) act
      -> Maybe (r s act ps o)
      -> Effect (r s act ps o)
  , renderChild :: forall s act ps o. r s act ps o -> r s act ps o
  , removeChild :: forall s act ps o. r s act ps o -> Effect Unit
  , dispose :: forall s act ps o. r s act ps o -> Effect Unit
  }

runUI
  :: forall h r f i o
   . RenderSpec h r
  -> Component h f i o Aff
  -> i
  -> Aff (HalogenIO f o Aff)
runUI renderSpec component i = do
  lchs <- liftEffect newLifecycleHandlers
  fresh <- liftEffect $ Ref.new 0
  disposed <- liftEffect $ Ref.new false
  Eval.handleLifecycle lchs do
    listeners <- Ref.new M.empty
    dsx <- Ref.read =<< runComponent lchs (rootHandler listeners) i component
    unDriverStateX (\st ->
      pure
        { query: evalDriver disposed st.selfRef
        , subscribe: subscribe fresh listeners
        , dispose: dispose disposed lchs dsx listeners
        }) dsx

  where

  evalDriver
    :: forall s f' act ps i' o'
     . Ref Boolean
    -> Ref (DriverState h r s f' act ps i' o')
    -> forall a. (f' a -> Aff (Maybe a))
  evalDriver disposed ref q =
    liftEffect (Ref.read disposed) >>=
      if _
        then pure Nothing
        else Eval.evalQ render ref q

  rootHandler :: Ref (M.Map Int (AV.AVar o)) -> o -> Aff Unit
  rootHandler ref message = do
    listeners <- liftEffect $ Ref.read ref
    traverse_ fork $ map (AV.put message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o Aff Unit
    -> Aff Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.empty
    listenerId <- liftEffect do
      listenerId <- Ref.read fresh
      Ref.modify_ (_ + 1) fresh
      Ref.modify_ (M.insert listenerId inputVar) ref
      pure listenerId
    let producer = CR.producer $ either (const (Right unit)) Left <$> try (AV.take inputVar)
    void $ fork do
      CR.runProcess (CR.connect producer consumer)
      liftEffect $ Ref.modify_ (M.delete listenerId) ref
      AV.kill (error "ended") inputVar

  runComponent
    :: forall f' i' o'
     . Ref LifecycleHandlers
    -> (o' -> Aff Unit)
    -> i'
    -> Component h f' i' o' Aff
    -> Effect (Ref (DriverStateX h r f' o'))
  runComponent lchs handler j = unComponent \c -> do
    lchs' <- newLifecycleHandlers
    var <- initDriverState c j handler lchs'
    pre <- Ref.read lchs
    Ref.write { initializers: L.Nil, finalizers: pre.finalizers } lchs
    unDriverStateX (render lchs <<< _.selfRef) =<< Ref.read var
    squashChildInitializers lchs pre.initializers =<< Ref.read var
    pure var

  render
    :: forall s f' act ps i' o'
     . Ref LifecycleHandlers
    -> Ref (DriverState h r s f' act ps i' o')
    -> Effect Unit
  render lchs var = Ref.read var >>= \(DriverState ds) -> do
    shouldProcessHandlers <- isNothing <$> Ref.read ds.pendingHandlers
    when shouldProcessHandlers $ Ref.write (Just L.Nil) ds.pendingHandlers
    Ref.write Slot.empty ds.childrenOut
    Ref.write ds.children ds.childrenIn
    let
      handler :: Input act -> Aff Unit
      handler = Eval.queueOrRun ds.pendingHandlers <<< void <<< Eval.evalF render ds.selfRef
      childHandler :: act -> Aff Unit
      childHandler = Eval.queueOrRun ds.pendingQueries <<< handler <<< Input.Action
    rendering <-
      renderSpec.render
        (handleAff <<< handler)
        (renderChild lchs childHandler ds.childrenIn ds.childrenOut)
        (ds.component.render ds.state)
        ds.rendering
    children <- Ref.read ds.childrenOut
    childrenIn <- Ref.read ds.childrenIn
    Slot.foreachSlot childrenIn \(DriverStateRef childVar) -> do
      childDS <- Ref.read childVar
      renderStateX_ renderSpec.removeChild childDS
      finalize lchs childDS
    flip Ref.modify_ ds.selfRef $ mapDriverState \ds' ->
      ds' { rendering = Just rendering, children = children }
    when shouldProcessHandlers do
      flip tailRecM unit \_ -> do
        handlers <- Ref.read ds.pendingHandlers
        Ref.write (Just L.Nil) ds.pendingHandlers
        traverse_ (handleAff <<< traverse_ fork <<< L.reverse) handlers
        mmore <- Ref.read ds.pendingHandlers
        if maybe false L.null mmore
          then Ref.write Nothing ds.pendingHandlers $> Done unit
          else pure $ Loop unit

  renderChild
    :: forall ps act
     . Ref LifecycleHandlers
    -> (act -> Aff Unit)
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> Ref (Slot.SlotStorage ps (DriverStateRef h r))
    -> ComponentSlotBox h ps Aff act
    -> Effect (RenderStateX r)
  renderChild lchs handler childrenInRef childrenOutRef =
    unComponentSlot \slot -> do
      childrenIn <- Ref.read childrenInRef
      var <- case slot.pop childrenIn of
        Just (Tuple (DriverStateRef existing) childrenIn') -> do
          Ref.write childrenIn' childrenInRef
          dsx <- Ref.read existing
          unDriverStateX (\st -> do
            flip Ref.write st.handlerRef $ maybe (pure unit) handler <<< slot.output
            handleAff $ Eval.evalM render st.selfRef (st.component.eval slot.input)) dsx
          pure existing
        Nothing ->
          case slot.input of
            HQ.Receive si _ ->
              runComponent lchs (maybe (pure unit) handler <<< slot.output) si slot.component
            _ ->
              throw "Halogen internal error: slot input was not a Receive query"
      isDuplicate <- isJust <<< slot.get <$> Ref.read childrenOutRef
      when isDuplicate
        $ warn "Halogen: Duplicate slot address was detected during rendering, unexpected results may occur"
      Ref.modify_ (slot.set $ DriverStateRef var) childrenOutRef
      Ref.read var >>= renderStateX case _ of
        Nothing -> throw "Halogen internal error: child was not initialized in renderChild"
        Just r -> pure (renderSpec.renderChild r)

  squashChildInitializers
    :: forall f' o'
     . Ref LifecycleHandlers
    -> L.List (Aff Unit)
    -> DriverStateX h r f' o'
    -> Effect Unit
  squashChildInitializers lchs preInits =
    unDriverStateX \st -> do
      let parentInitializer = Eval.evalM render st.selfRef (st.component.eval (HQ.Initialize unit))
      Ref.modify_ (\handlers ->
        { initializers: (do
            parSequence_ (L.reverse handlers.initializers)
            parentInitializer
            liftEffect do
              handlePending st.pendingQueries
              handlePending st.pendingOuts) : preInits
        , finalizers: handlers.finalizers
        }) lchs

  finalize
    :: forall f' o'
     . Ref LifecycleHandlers
    -> DriverStateX h r f' o'
    -> Effect Unit
  finalize lchs = do
    unDriverStateX \st -> do
      cleanupSubscriptionsAndForks (DriverState st)
      let f = Eval.evalM render st.selfRef (st.component.eval (HQ.Finalize unit))
      Ref.modify_ (\handlers ->
        { initializers: handlers.initializers
        , finalizers: f : handlers.finalizers
        }) lchs
      Slot.foreachSlot st.children \(DriverStateRef ref) -> do
        dsx <- Ref.read ref
        finalize lchs dsx

  dispose :: forall f' o'
     . Ref Boolean
    -> Ref LifecycleHandlers
    -> DriverStateX h r f' o'
    -> Ref (M.Map Int (AV.AVar o'))
    -> Aff Unit
  dispose disposed lchs dsx subsRef = liftEffect $
    Ref.read disposed >>=
      if _
        then pure unit
        else do
          Ref.write true disposed
          traverse_ (launchAff_ <<< AV.kill (error "disposed")) =<< Ref.read subsRef
          finalize lchs dsx
          unDriverStateX (traverse_ renderSpec.dispose <<< _.rendering) dsx

newLifecycleHandlers :: Effect (Ref LifecycleHandlers)
newLifecycleHandlers = Ref.new { initializers: L.Nil, finalizers: L.Nil }

handlePending :: Ref (Maybe (L.List (Aff Unit))) -> Effect Unit
handlePending ref = do
  queue <- Ref.read ref
  Ref.write Nothing ref
  for_ queue (handleAff <<< traverse_ fork <<< L.reverse)

cleanupSubscriptionsAndForks
  :: forall h r s f act ps i o
   . DriverState h r s f act ps i o
  -> Effect Unit
cleanupSubscriptionsAndForks (DriverState ds) = do
  traverse_ (handleAff <<< traverse_ (fork <<< ES.finalize)) =<< Ref.read ds.subscriptions
  Ref.write Nothing ds.subscriptions
  traverse_ (handleAff <<< killFiber (error "finalized")) =<< Ref.read ds.forks
  Ref.write M.empty ds.forks

-- We could perhaps do something more intelligent now this isn't baked into
-- the virtual-dom rendering. It hasn't really been a problem so far though.
handleAff :: forall a. Aff a -> Effect Unit
handleAff = runAff_ (either throwException (const (pure unit)))