unfolding Count (#5)

unfolding Count (#5)

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.DimensionPicker.Column where

import SlamData.Prelude

import Control.Comonad (extract)
import Control.Comonad.Cofree as CF

import Data.Argonaut as J
import Data.List ((:))
import Data.List as L

import SlamData.Workspace.Card.Setups.Chart.PivotTable.Model (Column(..))
import SlamData.Workspace.Card.Setups.DimensionPicker.JCursor (unfoldJCursor)
import SlamData.Workspace.Card.Setups.DimensionPicker.Node (discriminateNodes)
import SlamData.Workspace.MillerColumns.TreeData (constructTree)

type ColumnNode = Either Column Column

groupColumns ∷ L.List Column → CF.Cofree L.List ColumnNode
groupColumns cs =
  let
    root = Column J.JCursorTop
    tree = constructTree unfoldColumn root cs
  in
    discriminateNodes
      if extract <$> CF.tail tree == pure Count
      then CF.mkCofree root (CF.mkCofree Count L.Nil : CF.mkCofree root L.Nil : L.Nil)
      else tree

unfoldColumn :: Column → Maybe (Tuple Column Column)
unfoldColumn col = case col of
  Count → Just $ Tuple Count $ Column J.JCursorTop
  Column value →
    unfoldJCursor value <#> \(Tuple _ rest) → Tuple col (Column rest)

showColumn ∷ (J.JCursor → String) → Column → String
showColumn f (Column value ) = f value
showColumn _ Count = "COUNT"

flattenColumns ∷ ColumnNode → Column
flattenColumns = either id id

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.DimensionPicker.Column where

import SlamData.Prelude

import Control.Comonad (extract)
import Control.Comonad.Cofree as CF

import Data.Argonaut as J
import Data.List ((:))
import Data.List as L

import SlamData.Workspace.Card.Setups.Chart.PivotTable.Model (Column(..))
import SlamData.Workspace.Card.Setups.DimensionPicker.JCursor (unfoldJCursor)
import SlamData.Workspace.Card.Setups.DimensionPicker.Node (discriminateNodes)
import SlamData.Workspace.MillerColumns.TreeData (constructTree)

type ColumnNode = Either Column Column

groupColumns ∷ L.List Column → CF.Cofree L.List ColumnNode
groupColumns cs =
  let
    root = Column J.JCursorTop
    tree = constructTree unfoldColumn root cs
  in
    discriminateNodes
      if extract <$> CF.tail tree == pure Count
      then CF.mkCofree root (CF.mkCofree Count L.Nil : CF.mkCofree root L.Nil : L.Nil)
      else tree

unfoldColumn :: Column → Maybe (Tuple Column Column)
unfoldColumn col = case col of
  Count → Nothing
  Column value →
    unfoldJCursor value <#> \(Tuple _ rest) → Tuple col (Column rest)

showColumn ∷ (J.JCursor → String) → Column → String
showColumn f (Column value ) = f value
showColumn _ Count = "COUNT"

flattenColumns ∷ ColumnNode → Column
flattenColumns = either id id


Remove unneccesary transformer from chapter 2, new level 2.1

module Levels.Chapter2 where

import Data.Array
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

chapter2 :: Chapter
chapter2 = {
    name: "Chapter 2",

    transformers: SM.fromList [
        "mapYtoYR" :> {
            name: "map({Yellow} ↦ {Yellow}{Red})",
            function: tReplaceMultiple Yellow [Yellow, Red]
        },
        "mapCtoRC" :> {
            name: "map({Cyan} ↦ {Red}{Cyan})",
            function: tReplaceMultiple Cyan [Red, Cyan]
        },
        "rejectY" :> {
            name: "reject({Yellow})",
            function: map (reject (== Yellow)) >>> tClearEmpty
        },
        "rejectC" :> {
            name: "reject({Cyan})",
            function: map (reject (== Cyan)) >>> tClearEmpty
        },
        "filterContainsR" :> {
            name: "filter(contains({Red}))",
            function: filter (\stack -> Red `elemIndex` stack /= -1) >>> tClearEmpty
        },
        "mapPushR" :> {
            name: "map(push({Red}))",
            function: map (`snoc` Red)
        },
        "mapReverse" :> {
            name: "map(reverse)",
            function: map reverse
        }
    ],

    levels: SM.fromList [
        "2.1" :> {
            name: "Mercury",
            difficulty: Easy,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red], [Red, Red], [Red, Red], [Red, Red]]
        },
        "2.2" :> {
            name: "Venus",
            difficulty: Easy,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red], [Red, Red]]
        },
        "2.3" :> {
            name: "Earth",
            difficulty: Easy,
            initial: [[Cyan, Cyan, Yellow], [Cyan, Red], [Cyan, Red], [Cyan, Cyan, Yellow]],
            target: [[Red, Cyan, Cyan], [Red, Cyan], [Red, Cyan], [Red, Cyan, Cyan]]
        },
        "2.4" :> {
            name: "Mars",
            difficulty: Easy,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red, Red], [Red, Yellow, Red], [Red, Yellow, Red], [Red, Red, Red]]
        }
    ]
}

module Levels.Chapter2 where

import Data.Array
import qualified Data.StrMap as SM

import Helper
import Transformer
import Types

chapter2 :: Chapter
chapter2 = {
    name: "Chapter 2",

    transformers: SM.fromList [
        "rejectSizeG2" :> {
            name: "reject(size > 2)",
            function: reject (\x -> length x > 2)
        },
        "mapYtoYR" :> {
            name: "map({Yellow} ↦ {Yellow}{Red})",
            function: tReplaceMultiple Yellow [Yellow, Red]
        },
        "mapCtoRC" :> {
            name: "map({Cyan} ↦ {Red}{Cyan})",
            function: tReplaceMultiple Cyan [Red, Cyan]
        },
        "rejectY" :> {
            name: "reject({Yellow})",
            function: map (reject (== Yellow)) >>> tClearEmpty
        },
        "rejectC" :> {
            name: "reject({Cyan})",
            function: map (reject (== Cyan)) >>> tClearEmpty
        },
        "filterContainsR" :> {
            name: "filter(contains({Red}))",
            function: filter (\stack -> Red `elemIndex` stack /= -1) >>> tClearEmpty
        },
        "mapPushR" :> {
            name: "map(push({Red}))",
            function: map (`snoc` Red)
        },
        "mapReverse" :> {
            name: "map(reverse)",
            function: map reverse
        }
    ],

    levels: SM.fromList [
        "2.1" :> {
            name: "Mercury",
            difficulty: Easy,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red]]
        },
        "2.2" :> {
            name: "Venus",
            difficulty: Easy,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red], [Red, Red]]
        },
        "2.3" :> {
            name: "Earth",
            difficulty: Easy,
            initial: [[Cyan, Cyan, Yellow], [Cyan, Red], [Cyan, Red], [Cyan, Cyan, Yellow]],
            target: [[Red, Cyan, Cyan], [Red, Cyan], [Red, Cyan], [Red, Cyan, Cyan]]
        },
        "2.4" :> {
            name: "Mars",
            difficulty: Easy,
            initial: [[Red, Red], [Red, Yellow], [Cyan, Yellow], [Cyan, Cyan]],
            target: [[Red, Red, Red], [Red, Yellow, Red], [Red, Yellow, Red], [Red, Red, Red]]
        }
    ]
}


pull out stupid state signal hackage

pull out stupid state signal hackage

module CalendarChart.Main where

import Data.Maybe

import Data.JSON

import CalendarChart.Chart
import CalendarChart.Activities
import CalendarChart.Strava
import CalendarChart.RA
import CalendarChart.Util

import Data.Array(map,mapMaybe,length,filter,concat)
import Debug.Trace
import Data.Date
import Data.Tuple

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Class(liftEff)
import Control.Monad.Aff(launchAff,Aff())
import Network.HTTP.Affjax

import qualified Browser.WebStorage as WS

import Data.Either
import Control.Bind
import DOM
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Halogen
import Halogen.Signal
import Halogen.Component
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import Control.Functor (($>))
import Control.Plus (empty)

fetchCont :: ([Activity] -> Eff _ (Unit)) -> Aff _ Unit
fetchCont chartf = do
  strava <- get "data/activities.json"
  let vals = fromMaybe [] $ decode $ strava.response
  ra <- get "data/log.txt"
  pp <- liftEff $ getRAfromText ra.response
  let acts = filter (\(Activity a) -> a.type == Run) $ vals ++ pp
  liftEff $ do
    chartf acts
    callPhantom false

mainWeek :: JSDate -> Eff _ Unit
mainWeek jsd =
  launchAff (fetchCont $ chartWeek dt)
  where
    dt :: Date
    dt = Data.Maybe.Unsafe.fromJust $ fromJSDate jsd

mainMonths = launchAff (fetchCont chartMonths)

chart = chartMonths <<< filter (\(Activity a) -> a.type == Run)

stravaTokenKey = "stravaToken"

downloadStrava :: _ -> Eff _ Unit
downloadStrava _ = do
  let stravaUrl = "https://www.strava.com/oauth/authorize?client_id=2746&response_type=code&redirect_uri=http://localhost:8123/token_exchange&scope=public&state=mystate&approval_prompt=force"
  cachedToken <- WS.getItem WS.localStorage stravaTokenKey
  case cachedToken of
    Nothing -> do
      openWindow stravaUrl "login" "height=600,width=800"
      trace "Downloading Strava"
    Just token -> do
      trace "Got cached token"
      downloadedStrava token
      trace "xxx"

-- called externally
downloadedStrava :: String -> Eff _ Unit
downloadedStrava token = do
  trace $ "Strava callback complete: " ++ token
  WS.setItem WS.localStorage stravaTokenKey token
  fetchStrava 1 token
  trace "42"

fetchStrava :: Number -> String -> Eff _ Unit
fetchStrava page token = do
  trace "About to fetch strava data"
  let url = "https://www.strava.com/api/v3/athlete/activities?per_page=200" ++ "&page=" ++ (show page) ++ "&access_token=" ++ token ++ "&callback={callback}"

  jsonp url (\result -> do
    trace "fetched strava data"
    let stravaData = getStravaFromText result
    -- cb <- combinedCallback stravaData
    -- cb unit
    return unit
  )

appendToBody :: forall eff. HTMLElement -> Eff (dom :: DOM | eff) Unit
appendToBody e = document globalWindow >>= (body >=> flip appendChild e)

-- | The state of the application
data State = State [[Activity]]

-- | Inputs to the state machine
data Input = Data [Activity] | CurrentState [[Activity]]

ui :: Component (E.Event (HalogenEffects _)) Input Input
ui = render <$> stateful (State []) update
  where
  render :: State -> H.HTML (E.Event (HalogenEffects _) Input)
  render (State s) = H.div_
    [ H.text "Upload data (RunningAhead csv format): "
    , H.input [ A.type_ "file", A.onChange $ \e -> pure (do
        text <- E.async $ getFile e
        liftEff $ trace "Got RA data"
        ra <- liftEff $ getRAfromText text
        stateInput s ra
      ) ] []

    , H.text "Upload data (Strava saved JSON format): "
    , H.input [ A.type_ "file", A.onChange $ \e -> pure (do
        text <- E.async $ getFile e
        liftEff $ trace "Got Strava data"
        let sa = getStravaFromText text
        stateInput s sa
      ) ] []

    , H.button [ A.onClick $ \_ -> pure (do
        liftEff $ downloadStrava unit
        empty
      ) ] [ H.text "Connect to Strava"]

    , H.p_ [ H.text $ "Files uploaded: " ++ show (length s) ]

    , H.div [ A.classes [A.className "monthchart", A.className "hcl2"] ] []
    ]

  getFile e =
    case getElementFile e.target of
      Nothing -> return ""
      Just f -> readAsTextAff (fileReader unit) (fileAsBlob f)

  stateInput s i = pure (Data i) <> pure (CurrentState $ updateState s i)

  updateState s a = a : s

  update :: State -> Input -> State
  update (State s) (Data a) = State (updateState s a)
  update s _ = s

mainInteractive = do
  Tuple node _ <- runUIWith ui (\req elt driver -> do
    trace "runUi callback"
    case req of
      Data _ -> return unit
      CurrentState acts -> chart $ concat acts
    )
  appendToBody node

  return unit

main = mainInteractive

module CalendarChart.Main where

import Data.Maybe

import Data.JSON

import CalendarChart.Chart
import CalendarChart.Activities
import CalendarChart.Strava
import CalendarChart.RA
import CalendarChart.Util

import Data.Array(map,mapMaybe,length,filter,concat)
import Debug.Trace
import Data.Date
import Data.Tuple

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Class(liftEff)
import Control.Monad.Aff(launchAff,Aff())
import Network.HTTP.Affjax

import qualified Browser.WebStorage as WS

import Data.Either
import Control.Bind
import DOM
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Halogen
import Halogen.Signal
import Halogen.Component
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import Control.Functor (($>))
import Control.Plus (empty)

fetchCont :: ([Activity] -> Eff _ (Unit)) -> Aff _ Unit
fetchCont chartf = do
  strava <- get "data/activities.json"
  let vals = fromMaybe [] $ decode $ strava.response
  ra <- get "data/log.txt"
  pp <- liftEff $ getRAfromText ra.response
  let acts = filter (\(Activity a) -> a.type == Run) $ vals ++ pp
  liftEff $ do
    chartf acts
    callPhantom false

mainWeek :: JSDate -> Eff _ Unit
mainWeek jsd =
  launchAff (fetchCont $ chartWeek dt)
  where
    dt :: Date
    dt = Data.Maybe.Unsafe.fromJust $ fromJSDate jsd

mainMonths = launchAff (fetchCont chartMonths)

chart = chartMonths <<< filter (\(Activity a) -> a.type == Run)

stravaTokenKey = "stravaToken"

downloadStrava :: _ -> Eff _ Unit
downloadStrava _ = do
  let stravaUrl = "https://www.strava.com/oauth/authorize?client_id=2746&response_type=code&redirect_uri=http://localhost:8123/token_exchange&scope=public&state=mystate&approval_prompt=force"
  cachedToken <- WS.getItem WS.localStorage stravaTokenKey
  case cachedToken of
    Nothing -> do
      openWindow stravaUrl "login" "height=600,width=800"
      trace "Downloading Strava"
    Just token -> do
      trace "Got cached token"
      downloadedStrava token
      trace "xxx"

-- called externally
downloadedStrava :: String -> Eff _ Unit
downloadedStrava token = do
  trace $ "Strava callback complete: " ++ token
  WS.setItem WS.localStorage stravaTokenKey token
  fetchStrava 1 token
  trace "42"

fetchStrava :: Number -> String -> Eff _ Unit
fetchStrava page token = do
  trace "About to fetch strava data"
  let url = "https://www.strava.com/api/v3/athlete/activities?per_page=200" ++ "&page=" ++ (show page) ++ "&access_token=" ++ token ++ "&callback={callback}"

  jsonp url (\result -> do
    trace "fetched strava data"
    let stravaData = getStravaFromText result
    -- cb <- combinedCallback stravaData
    -- cb unit
    return unit
  )

appendToBody :: forall eff. HTMLElement -> Eff (dom :: DOM | eff) Unit
appendToBody e = document globalWindow >>= (body >=> flip appendChild e)

-- | The state of the application
data State = State [[Activity]]

-- | Inputs to the state machine
data Input = Data [Activity] | CurrentState [[Activity]]

ui :: Component (E.Event (HalogenEffects _)) Input Input
ui = render <$> stateful (State []) update
  where
  render :: State -> H.HTML (E.Event (HalogenEffects _) Input)
  render (State s) = H.div_
    [ H.text "Upload data (RunningAhead csv format): "
    , H.input [ A.type_ "file", A.onChange $ \e -> pure (do
        text <- E.async $ case getElementFile e.target of
          Nothing -> return ""
          Just f -> readAsTextAff (fileReader unit) (fileAsBlob f)
        liftEff $ trace "Got RA data"
        ra <- liftEff $ getRAfromText text
        pure (Data ra) <> pure (CurrentState $ ra:s)
      ) ] []
    , H.text "Upload data (Strava saved JSON format): "
    , H.input [ A.type_ "file", A.onChange $ \e -> pure (do
        text <- E.async $ case getElementFile e.target of
          Nothing -> return ""
          Just f -> readAsTextAff (fileReader unit) (fileAsBlob f)
        liftEff $ trace "Got Strava data"
        let sa = getStravaFromText text
        pure (Data sa) <> pure (CurrentState $ sa:s)
      ) ] []

    , H.button [ A.onClick $ \_ -> pure (do
        liftEff $ downloadStrava unit
        empty
      ) ] [ H.text "Connect to Strava"]

    , H.p_ [ H.text $ "Files uploaded: " ++ show (length s) ]

    , H.div [ A.classes [A.className "monthchart", A.className "hcl2"]
    ] []
    ]

  update :: State -> Input -> State
  update (State s) (Data a) = State (a:s)
  update s _ = s

mainInteractive = do
  Tuple node _ <- runUIWith ui (\req elt driver -> do
    case req of
      Data _ -> return unit
      CurrentState acts -> chart $ concat acts
    )
  appendToBody node

  return unit

main = mainInteractive


Fix duplicate check

Fix duplicate check

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

import Prelude

import Control.Coroutine as CR
import Control.Monad.Aff (Aff, runAff_)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (warn)
import Control.Monad.Eff.Exception (error, throw, throwException)
import Control.Monad.Eff.Ref (Ref, modifyRef, writeRef, readRef, newRef)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
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_, sequence_)
import Data.Tuple (Tuple(..))
import Halogen (HalogenIO)
import Halogen.Aff.Driver.Eval (eval, handleLifecycle, queuingHandler)
import Halogen.Aff.Driver.State (DriverState(..), DriverStateRef(..), DriverStateX, LifecycleHandlers, RenderStateX, initDriverState, renderStateX, renderStateX_, unDriverStateX)
import Halogen.Aff.Effects (HalogenEffects)
import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.Slot as Slot
import Halogen.Query.InputF (InputF(..))

-- | `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.
-- | - `eff` is the type variable for the open effect row.
-- |
-- | The "inner" type variables, used by `r` and the other functions are as
-- | follows:
-- | - `s` is the state type for the component.
-- | - `f` is the query algebra for the component.
-- | - `g` is the query algebra for the component's children.
-- | - `p` is the slot address value type.
-- | - `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 `id`. 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)`.
type RenderSpec h r eff =
  { render
      :: forall s f ps o
       . (forall x. InputF x (f x) -> Eff (HalogenEffects eff) Unit)
      -> (ComponentSlot h ps (Aff (HalogenEffects eff)) (f Unit) -> Eff (HalogenEffects eff) (RenderStateX r eff))
      -> h (ComponentSlot h ps (Aff (HalogenEffects eff)) (f Unit)) (f Unit)
      -> Maybe (r s f ps o eff)
      -> Eff (HalogenEffects eff) (r s f ps o eff)
  , renderChild :: forall s f ps o. r s f ps o eff -> r s f ps o eff
  , removeChild :: forall s f ps o. r s f ps o eff -> Eff (HalogenEffects eff) Unit
  }

newLifecycleHandlers :: forall eff. Eff (HalogenEffects eff) (Ref (LifecycleHandlers eff))
newLifecycleHandlers = newRef { initializers: L.Nil, finalizers: L.Nil }

runUI
  :: forall h r f i o eff
   . RenderSpec h r eff
  -> Component h f i o (Aff (HalogenEffects eff))
  -> i
  -> Aff (HalogenEffects eff) (HalogenIO f o (Aff (HalogenEffects eff)))
runUI renderSpec component i = do
  lchs <- liftEff newLifecycleHandlers
  fresh <- liftEff $ newRef 0
  handleLifecycle lchs do
    listeners <- newRef M.empty
    runComponent lchs (rootHandler listeners) i component
      >>= readRef
      >>= unDriverStateX \st ->
        pure
          { query: evalDriver st.selfRef
          , subscribe: subscribe fresh listeners
          }

  where

  evalDriver
    :: forall s' f' ps' i' o'
     . Ref (DriverState h r s' f' ps' i' o' eff)
    -> f'
    ~> Aff (HalogenEffects eff)
  evalDriver ref q =
    evalF ref (Query q)

  evalF
    :: forall s' f' ps' i' o' a
     . Ref (DriverState h r s' f' ps' i' o' eff)
    -> InputF a (f' a)
    -> Aff (HalogenEffects eff) a
  evalF ref = eval render ref

  rootHandler
    :: Ref (M.Map Int (AV.AVar o))
    -> o
    -> Aff (HalogenEffects eff) Unit
  rootHandler ref message = do
    listeners <- liftEff $ readRef ref
    traverse_ fork $ map (AV.putVar message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o (Aff (HalogenEffects eff)) Unit
    -> Aff (HalogenEffects eff) Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.makeEmptyVar
    listenerId <- liftEff do
      listenerId <- readRef fresh
      modifyRef fresh (_ + 1)
      modifyRef ref (M.insert listenerId inputVar)
      pure listenerId
    let producer = CR.producer (Left <$> AV.takeVar inputVar)
    void $ fork do
      CR.runProcess (CR.connect producer consumer)
      liftEff $ modifyRef ref (M.delete listenerId)
      AV.killVar (error "ended") inputVar

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

  render
    :: forall s' f' ps' i' o'
     . Ref (LifecycleHandlers eff)
    -> Ref (DriverState h r s' f' ps' i' o' eff)
    -> Eff (HalogenEffects eff) Unit
  render lchs var = readRef var >>= \(DriverState ds) -> do
    shouldProcessHandlers <- isNothing <$> readRef ds.pendingHandlers
    when shouldProcessHandlers $ writeRef ds.pendingHandlers (Just L.Nil)
    writeRef ds.childrenOut Slot.empty
    writeRef ds.childrenIn ds.children
    let
      handler :: forall x. InputF x (f' x) -> Aff (HalogenEffects eff) Unit
      handler = queuingHandler (void <<< evalF ds.selfRef) ds.pendingHandlers
      childHandler :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      childHandler = queuingHandler (handler <<< Query) ds.pendingQueries
    rendering <-
      renderSpec.render
        (handleAff <<< handler)
        (renderChild lchs childHandler ds.childrenIn ds.childrenOut)
        (ds.component.render ds.state)
        ds.rendering
    children <- readRef ds.childrenOut
    childrenIn <- readRef ds.childrenIn
    Slot.foreachSlot childrenIn \(DriverStateRef childVar) -> do
      childDS <- readRef childVar
      renderStateX_ renderSpec.removeChild childDS
      finalize lchs childDS
    modifyRef ds.selfRef \(DriverState ds') ->
      DriverState
        { rendering: Just rendering
        , children
        , component: ds'.component
        , state: ds'.state
        , refs: ds'.refs
        , childrenIn: ds'.childrenIn
        , childrenOut: ds'.childrenOut
        , selfRef: ds'.selfRef
        , handlerRef: ds'.handlerRef
        , pendingQueries: ds'.pendingQueries
        , pendingOuts: ds'.pendingOuts
        , pendingHandlers: ds'.pendingHandlers
        , fresh: ds'.fresh
        , subscriptions: ds'.subscriptions
        , lifecycleHandlers: ds'.lifecycleHandlers
        }
    when shouldProcessHandlers do
      flip tailRecM unit \_ -> do
        handlers <- readRef ds.pendingHandlers
        writeRef ds.pendingHandlers (Just L.Nil)
        traverse_ (handleAff <<< traverse_ fork <<< L.reverse) handlers
        mmore <- readRef ds.pendingHandlers
        if maybe false L.null mmore
          then writeRef ds.pendingHandlers Nothing $> Done unit
          else pure $ Loop unit

  renderChild
    :: forall ps' f'
     . Ref (LifecycleHandlers eff)
    -> (forall x. f' x -> Aff (HalogenEffects eff) Unit)
    -> Ref (Slot.SlotStorage ps' (DriverStateRef h r eff))
    -> Ref (Slot.SlotStorage ps' (DriverStateRef h r eff))
    -> ComponentSlot h ps' (Aff (HalogenEffects eff)) (f' Unit)
    -> Eff (HalogenEffects eff) (RenderStateX r eff)
  renderChild lchs handler childrenInRef childrenOutRef =
    unComponentSlot \slot -> do
      childrenIn <- readRef childrenInRef
      var <- case slot.pop childrenIn of
        Just (Tuple (DriverStateRef existing) childrenIn') -> do
          writeRef childrenInRef childrenIn'
          dsx <- readRef existing
          unDriverStateX (\st -> do
            writeRef st.handlerRef $ maybe (pure unit) handler <<< slot.output
            let inputQuery = unComponent _.receiver slot.component
            for_ (inputQuery slot.input) \q ->
              handleAff $ evalF st.selfRef (Query q)) dsx
          pure existing
        Nothing ->
          runComponent lchs (maybe (pure unit) handler <<< slot.output) slot.input slot.component
      isDuplicate <- isJust <<< slot.get <$> readRef childrenOutRef
      when isDuplicate
        $ unsafeCoerceEff
        $ warn "Halogen: Duplicate slot address was detected during rendering, unexpected results may occur"
      modifyRef childrenOutRef (slot.set $ DriverStateRef var)
      readRef 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 eff)
    -> L.List (Aff (HalogenEffects eff) Unit)
    -> DriverStateX h r eff f' o'
    -> Eff (HalogenEffects eff) Unit
  squashChildInitializers lchs preInits =
    unDriverStateX \st -> do
      let parentInitializer = evalF st.selfRef <<< Query <$> st.component.initializer
      modifyRef lchs \handlers ->
        { initializers: (do
            parSequence_ (L.reverse handlers.initializers)
            sequence_ parentInitializer
            liftEff do
              handlePending st.pendingQueries
              handlePending st.pendingOuts) : preInits
        , finalizers: handlers.finalizers
        }

  handlePending
    :: Ref (Maybe (L.List (Aff (HalogenEffects eff) Unit)))
    -> Eff (HalogenEffects eff) Unit
  handlePending ref = do
    queue <- readRef ref
    writeRef ref Nothing
    for_ queue (handleAff <<< traverse_ fork <<< L.reverse)

  cleanupSubscriptions
    :: forall s' f' ps' i' o'
     . DriverState h r s' f' ps' i' o' eff
    -> Eff (HalogenEffects eff) Unit
  cleanupSubscriptions (DriverState ds) = do
    traverse_ (handleAff <<< traverse_ fork) =<< readRef ds.subscriptions
    writeRef ds.subscriptions Nothing

  finalize
    :: forall f' o'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r eff f' o'
    -> Eff (HalogenEffects eff) Unit
  finalize lchs = do
    unDriverStateX \st -> do
      cleanupSubscriptions (DriverState st)
      for_ (evalF st.selfRef <<< Query <$> st.component.finalizer) \f ->
        modifyRef lchs (\handlers ->
          { initializers: handlers.initializers
          , finalizers: f : handlers.finalizers
          })
      Slot.foreachSlot st.children \(DriverStateRef ref) -> do
        dsx <- readRef ref
        finalize lchs dsx

-- | TODO: we could do something more intelligent now this isn't baked into the
-- | virtual-dom rendering. Perhaps write to an avar when an error occurs...
-- | something other than a runtime exception anyway.
handleAff
  :: forall eff a
   . Aff (HalogenEffects eff) a
  -> Eff (HalogenEffects eff) Unit
handleAff = runAff_ (either throwException (const (pure unit)))

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

import Prelude

import Control.Coroutine as CR
import Control.Monad.Aff (Aff, runAff_)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (warn)
import Control.Monad.Eff.Exception (error, throw, throwException)
import Control.Monad.Eff.Ref (Ref, modifyRef, writeRef, readRef, newRef)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
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, isNothing)
import Data.Traversable (for_, traverse_, sequence_)
import Data.Tuple (Tuple(..))
import Halogen (HalogenIO)
import Halogen.Aff.Driver.Eval (eval, handleLifecycle, queuingHandler)
import Halogen.Aff.Driver.State (DriverState(..), DriverStateRef(..), DriverStateX, LifecycleHandlers, RenderStateX, initDriverState, renderStateX, renderStateX_, unDriverStateX)
import Halogen.Aff.Effects (HalogenEffects)
import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.Slot as Slot
import Halogen.Query.InputF (InputF(..))

-- | `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.
-- | - `eff` is the type variable for the open effect row.
-- |
-- | The "inner" type variables, used by `r` and the other functions are as
-- | follows:
-- | - `s` is the state type for the component.
-- | - `f` is the query algebra for the component.
-- | - `g` is the query algebra for the component's children.
-- | - `p` is the slot address value type.
-- | - `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 `id`. 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)`.
type RenderSpec h r eff =
  { render
      :: forall s f ps o
       . (forall x. InputF x (f x) -> Eff (HalogenEffects eff) Unit)
      -> (ComponentSlot h ps (Aff (HalogenEffects eff)) (f Unit) -> Eff (HalogenEffects eff) (RenderStateX r eff))
      -> h (ComponentSlot h ps (Aff (HalogenEffects eff)) (f Unit)) (f Unit)
      -> Maybe (r s f ps o eff)
      -> Eff (HalogenEffects eff) (r s f ps o eff)
  , renderChild :: forall s f ps o. r s f ps o eff -> r s f ps o eff
  , removeChild :: forall s f ps o. r s f ps o eff -> Eff (HalogenEffects eff) Unit
  }

newLifecycleHandlers :: forall eff. Eff (HalogenEffects eff) (Ref (LifecycleHandlers eff))
newLifecycleHandlers = newRef { initializers: L.Nil, finalizers: L.Nil }

runUI
  :: forall h r f i o eff
   . RenderSpec h r eff
  -> Component h f i o (Aff (HalogenEffects eff))
  -> i
  -> Aff (HalogenEffects eff) (HalogenIO f o (Aff (HalogenEffects eff)))
runUI renderSpec component i = do
  lchs <- liftEff newLifecycleHandlers
  fresh <- liftEff $ newRef 0
  handleLifecycle lchs do
    listeners <- newRef M.empty
    runComponent lchs (rootHandler listeners) i component
      >>= readRef
      >>= unDriverStateX \st ->
        pure
          { query: evalDriver st.selfRef
          , subscribe: subscribe fresh listeners
          }

  where

  evalDriver
    :: forall s' f' ps' i' o'
     . Ref (DriverState h r s' f' ps' i' o' eff)
    -> f'
    ~> Aff (HalogenEffects eff)
  evalDriver ref q =
    evalF ref (Query q)

  evalF
    :: forall s' f' ps' i' o' a
     . Ref (DriverState h r s' f' ps' i' o' eff)
    -> InputF a (f' a)
    -> Aff (HalogenEffects eff) a
  evalF ref = eval render ref

  rootHandler
    :: Ref (M.Map Int (AV.AVar o))
    -> o
    -> Aff (HalogenEffects eff) Unit
  rootHandler ref message = do
    listeners <- liftEff $ readRef ref
    traverse_ fork $ map (AV.putVar message) listeners

  subscribe
    :: Ref Int
    -> Ref (M.Map Int (AV.AVar o))
    -> CR.Consumer o (Aff (HalogenEffects eff)) Unit
    -> Aff (HalogenEffects eff) Unit
  subscribe fresh ref consumer = do
    inputVar <- AV.makeEmptyVar
    listenerId <- liftEff do
      listenerId <- readRef fresh
      modifyRef fresh (_ + 1)
      modifyRef ref (M.insert listenerId inputVar)
      pure listenerId
    let producer = CR.producer (Left <$> AV.takeVar inputVar)
    void $ fork do
      CR.runProcess (CR.connect producer consumer)
      liftEff $ modifyRef ref (M.delete listenerId)
      AV.killVar (error "ended") inputVar

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

  render
    :: forall s' f' ps' i' o'
     . Ref (LifecycleHandlers eff)
    -> Ref (DriverState h r s' f' ps' i' o' eff)
    -> Eff (HalogenEffects eff) Unit
  render lchs var = readRef var >>= \(DriverState ds) -> do
    shouldProcessHandlers <- isNothing <$> readRef ds.pendingHandlers
    when shouldProcessHandlers $ writeRef ds.pendingHandlers (Just L.Nil)
    writeRef ds.childrenOut Slot.empty
    writeRef ds.childrenIn ds.children
    let
      handler :: forall x. InputF x (f' x) -> Aff (HalogenEffects eff) Unit
      handler = queuingHandler (void <<< evalF ds.selfRef) ds.pendingHandlers
      childHandler :: forall x. f' x -> Aff (HalogenEffects eff) Unit
      childHandler = queuingHandler (handler <<< Query) ds.pendingQueries
    rendering <-
      renderSpec.render
        (handleAff <<< handler)
        (renderChild lchs childHandler ds.childrenIn ds.childrenOut)
        (ds.component.render ds.state)
        ds.rendering
    children <- readRef ds.childrenOut
    childrenIn <- readRef ds.childrenIn
    Slot.foreachSlot childrenIn \(DriverStateRef childVar) -> do
      childDS <- readRef childVar
      renderStateX_ renderSpec.removeChild childDS
      finalize lchs childDS
    modifyRef ds.selfRef \(DriverState ds') ->
      DriverState
        { rendering: Just rendering
        , children
        , component: ds'.component
        , state: ds'.state
        , refs: ds'.refs
        , childrenIn: ds'.childrenIn
        , childrenOut: ds'.childrenOut
        , selfRef: ds'.selfRef
        , handlerRef: ds'.handlerRef
        , pendingQueries: ds'.pendingQueries
        , pendingOuts: ds'.pendingOuts
        , pendingHandlers: ds'.pendingHandlers
        , fresh: ds'.fresh
        , subscriptions: ds'.subscriptions
        , lifecycleHandlers: ds'.lifecycleHandlers
        }
    when shouldProcessHandlers do
      flip tailRecM unit \_ -> do
        handlers <- readRef ds.pendingHandlers
        writeRef ds.pendingHandlers (Just L.Nil)
        traverse_ (handleAff <<< traverse_ fork <<< L.reverse) handlers
        mmore <- readRef ds.pendingHandlers
        if maybe false L.null mmore
          then writeRef ds.pendingHandlers Nothing $> Done unit
          else pure $ Loop unit

  renderChild
    :: forall ps' f'
     . Ref (LifecycleHandlers eff)
    -> (forall x. f' x -> Aff (HalogenEffects eff) Unit)
    -> Ref (Slot.SlotStorage ps' (DriverStateRef h r eff))
    -> Ref (Slot.SlotStorage ps' (DriverStateRef h r eff))
    -> ComponentSlot h ps' (Aff (HalogenEffects eff)) (f' Unit)
    -> Eff (HalogenEffects eff) (RenderStateX r eff)
  renderChild lchs handler childrenInRef childrenOutRef =
    unComponentSlot \slot -> do
      childrenIn <- readRef childrenInRef
      var <- case slot.pop childrenIn of
        Just (Tuple (DriverStateRef existing) childrenIn') -> do
          writeRef childrenInRef childrenIn'
          dsx <- readRef existing
          unDriverStateX (\st -> do
            writeRef st.handlerRef $ maybe (pure unit) handler <<< slot.output
            let inputQuery = unComponent _.receiver slot.component
            for_ (inputQuery slot.input) \q ->
              handleAff $ evalF st.selfRef (Query q)) dsx
          pure existing
        Nothing ->
          runComponent lchs (maybe (pure unit) handler <<< slot.output) slot.input slot.component
      isDuplicate <- isNothing <<< slot.get <$> readRef childrenOutRef
      when isDuplicate
        $ unsafeCoerceEff
        $ warn "Halogen: Duplicate slot address was detected during rendering, unexpected results may occur"
      modifyRef childrenOutRef (slot.set $ DriverStateRef var)
      readRef 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 eff)
    -> L.List (Aff (HalogenEffects eff) Unit)
    -> DriverStateX h r eff f' o'
    -> Eff (HalogenEffects eff) Unit
  squashChildInitializers lchs preInits =
    unDriverStateX \st -> do
      let parentInitializer = evalF st.selfRef <<< Query <$> st.component.initializer
      modifyRef lchs \handlers ->
        { initializers: (do
            parSequence_ (L.reverse handlers.initializers)
            sequence_ parentInitializer
            liftEff do
              handlePending st.pendingQueries
              handlePending st.pendingOuts) : preInits
        , finalizers: handlers.finalizers
        }

  handlePending
    :: Ref (Maybe (L.List (Aff (HalogenEffects eff) Unit)))
    -> Eff (HalogenEffects eff) Unit
  handlePending ref = do
    queue <- readRef ref
    writeRef ref Nothing
    for_ queue (handleAff <<< traverse_ fork <<< L.reverse)

  cleanupSubscriptions
    :: forall s' f' ps' i' o'
     . DriverState h r s' f' ps' i' o' eff
    -> Eff (HalogenEffects eff) Unit
  cleanupSubscriptions (DriverState ds) = do
    traverse_ (handleAff <<< traverse_ fork) =<< readRef ds.subscriptions
    writeRef ds.subscriptions Nothing

  finalize
    :: forall f' o'
     . Ref (LifecycleHandlers eff)
    -> DriverStateX h r eff f' o'
    -> Eff (HalogenEffects eff) Unit
  finalize lchs = do
    unDriverStateX \st -> do
      cleanupSubscriptions (DriverState st)
      for_ (evalF st.selfRef <<< Query <$> st.component.finalizer) \f ->
        modifyRef lchs (\handlers ->
          { initializers: handlers.initializers
          , finalizers: f : handlers.finalizers
          })
      Slot.foreachSlot st.children \(DriverStateRef ref) -> do
        dsx <- readRef ref
        finalize lchs dsx

-- | TODO: we could do something more intelligent now this isn't baked into the
-- | virtual-dom rendering. Perhaps write to an avar when an error occurs...
-- | something other than a runtime exception anyway.
handleAff
  :: forall eff a
   . Aff (HalogenEffects eff) a
  -> Eff (HalogenEffects eff) Unit
handleAff = runAff_ (either throwException (const (pure unit)))


Use unit

Use unit

module Node.Buffer
  ( Octet()
  , Offset()
  , Buffer()
  , BufferWrite()
  , BufferValueType(..)
  , create
  , fromArray
  , fromString
  , read
  , readString
  , toString
  , write
  , writeString
  , toArray
  , getAtOffset
  , setAtOffset
  , size
  , concat
  , concat'
  , copy
  , fill
  ) where

import Control.Monad.Eff
import Data.Maybe
import Node.Encoding

-- |
-- Type synonym indicating the value should be an octet (0-255). If the value
-- provided is outside this range it will be used as modulo 255.
--
type Octet = Number

-- |
-- Type synonym indicating the value refers to an offset in a buffer.
--
type Offset = Number

-- |
-- An instance of Node's Buffer class.
--
foreign import data Buffer :: *

instance showBuffer :: Show Buffer where
  show = showImpl

foreign import showImpl "var showImpl = require('util').inspect;" :: Buffer -> String

-- |
-- Effect for buffer modification.
--
foreign import data BufferWrite :: !

-- |
-- Enumeration of the numeric types that can be written to a buffer.
--
data BufferValueType
  = UInt8
  | UInt16LE
  | UInt16BE
  | UInt32LE
  | UInt32BE
  | Int8
  | Int16LE
  | Int16BE
  | Int32LE
  | Int32BE
  | FloatLE
  | FloatBE
  | DoubleLE
  | DoubleBE

instance showBufferValueType :: Show BufferValueType where
  show UInt8    = "UInt8"
  show UInt16LE = "UInt16LE"
  show UInt16BE = "UInt16BE"
  show UInt32LE = "UInt32LE"
  show UInt32BE = "UInt32BE"
  show Int8     = "Int8"
  show Int16LE  = "Int16LE"
  show Int16BE  = "Int16BE"
  show Int32LE  = "Int32LE"
  show Int32BE  = "Int32BE"
  show FloatLE  = "FloatLE"
  show FloatBE  = "FloatBE"
  show DoubleLE = "DoubleLE"
  show DoubleBE = "DoubleBE"

-- |
-- Creates a new buffer of the specified size.
--
foreign import create
  "function create (size) { \
  \  return new Buffer(size); \
  \}" :: Number -> Buffer

-- |
-- Creates a new buffer from an array of octets, sized to match the array.
--
foreign import fromArray
  "function fromArray (octets) { \
  \  return new Buffer(octets); \
  \}" :: [Octet] -> Buffer

-- |
-- Creates a new buffer from a string with the specified encoding, sized to
-- match the string.
--
fromString :: String -> Encoding -> Buffer
fromString str = fromStringImpl str <<< show

foreign import fromStringImpl
  "function fromStringImpl (str) { \
  \  return function (encoding) { \
  \    return new Buffer(str, encoding); \
  \  }; \
  \}" :: String -> String -> Buffer

-- |
-- Reads a numeric value from a buffer at the specified offset.
--
read :: BufferValueType -> Offset -> Buffer -> Number
read = readImpl <<< show

foreign import readImpl
  "function readImpl (ty) { \
  \  return function (offset) { \
  \    return function (buf) { \
  \      return buf['read' + ty](offset); \
  \    }; \
  \  }; \
  \}" :: String -> Offset -> Buffer -> Number

-- |
-- Reads a section of a buffer as a string with the specified encoding.
--
readString :: forall e. Encoding -> Offset -> Offset -> Buffer -> String
readString = readStringImpl <<< show

foreign import readStringImpl
  "function readStringImpl (enc) { \
  \  return function (start) { \
  \    return function (end) { \
  \      return function (buff) { \
  \        return buff.toString(enc, start, end); \
  \      } \
  \    } \
  \  } \
  \}":: String -> Offset -> Offset -> Buffer -> String

-- |
-- Reads the buffer as a string with the specified encoding.
--
toString :: forall e. Encoding -> Buffer -> String
toString = toStringImpl <<< show

foreign import toStringImpl
  "function toStringImpl (enc) { \
  \  return function (buff) { \
  \    return buff.toString(enc); \
  \  } \
  \}":: String -> Buffer -> String

-- |
-- Writes a numeric value to a buffer at the specified offset.
--
write :: forall e. BufferValueType -> Number -> Offset -> Buffer -> Eff (buffer :: BufferWrite | e) Unit
write = writeImpl <<< show

foreign import writeImpl
  "function writeImpl (ty) { \
  \  return function (value) { \
  \    return function (offset) { \
  \      return function (buf) { \
  \        buf['write' + ty](value, offset); \
  \        return {}; \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall e. String -> Number -> Offset -> Buffer -> Eff (buffer :: BufferWrite | e) Unit

-- |
-- Writes octets from a string to a buffer at the specified offset. Multi-byte
-- characters will not be written to the buffer if there is not enough capacity
-- to write them fully. The number of bytes written is returned.
--
writeString :: forall e. Encoding -> Offset -> Number -> String -> Buffer -> Eff (buffer :: BufferWrite | e) Number
writeString = writeStringImpl <<< show

foreign import writeStringImpl
  "function writeStringImpl (enc) { \
  \  return function (offset) { \
  \      return function (length) { \
  \        return function (value) { \
  \          return function (buff) { \
  \            return buff.write(value, offset, length, encoding); \
  \          }; \
  \        }; \
  \      }; \
  \  }; \
  \}" :: forall e. String -> Offset -> Number -> String -> Buffer -> Eff (buffer :: BufferWrite | e) Number

-- |
-- Creates an array of octets from a buffer's contents.
--
foreign import toArray
  "function toArray (buff) { \
  \  return buff.toJSON(); \
  \}" :: Buffer -> [Octet]

-- |
-- Reads an octet from a buffer at the specified offset.
--
foreign import getAtOffset
  "function getAtOffset (buff) { \
  \  return function (offset) { \
  \    var octet = buff[offset]; \
  \    return octet == null ? _ps.Data_Maybe.Nothing \
  \                         : _ps.Data_Maybe.Just(buff[i]); \
  \  } \
  \}" :: Offset -> Buffer -> Maybe Octet

-- |
-- Writes an octet in the buffer at the specified offset.
--
foreign import setAtOffset
  "function setAtOffset (value) { \
  \  return function (offset) { \
  \    return function (buff) { \
  \      buff[offset] = value; \
  \      return {}; \
  \    } \
  \  } \
  \}" :: forall e. Octet -> Offset -> Buffer -> Eff (buffer :: BufferWrite | e) Unit

-- |
-- Returns the size of a buffer.
--
foreign import size
  "function size (buff) { \
  \  return buff.length; \
  \}" :: forall e. Buffer -> Number

-- |
-- Concatenates a list of buffers.
--
foreign import concat
  "function concat (buffs) { \
  \  return Buffer.concat(buffs); \
  \}" :: [Buffer] -> Buffer

-- |
-- Concatenates a list of buffers, combining them into a new buffer of the
-- specified length.
--
foreign import concat'
  "function concat$prime (buffs) { \
  \  return function (totalLength) { \
  \    return Buffer.concat(buffs, totalLength); \
  \  } \
  \}" :: [Buffer] -> Number -> Buffer

-- |
-- Copies a section of a source buffer into a target buffer at the specified
-- offset.
--
foreign import copy
  "function copy (srcStart) { \
  \  return function (srcEnd) { \
  \    return function (src) { \
  \      return function (targStart) { \
  \        return function (targ) { \
  \          return src.copy(targ, targStart, srcStart, strcEnd); \
  \        } \
  \      } \
  \    } \
  \  } \
  \}" :: Offset -> Offset -> Buffer -> Offset -> Buffer -> Buffer

-- |
-- Fills a range in a buffer with the specified octet.
--
foreign import fill
  "function fill (buff) { \
  \  return function (octet) { \
  \    return function (start) { \
  \      return function (end) { \
  \        buff.fill(octet, start, end); \
  \        return {}; \
  \      } \
  \    } \
  \  } \
  \}" :: forall e. Octet -> Offset -> Offset -> Buffer -> Eff (buffer :: BufferWrite | e) Unit

module Node.Buffer
  ( Octet()
  , Offset()
  , Buffer()
  , BufferWrite()
  , BufferValueType(..)
  , create
  , fromArray
  , fromString
  , read
  , readString
  , toString
  , write
  , writeString
  , toArray
  , getAtOffset
  , setAtOffset
  , size
  , concat
  , concat'
  , copy
  , fill
  ) where

import Control.Monad.Eff
import Data.Maybe
import Node.Encoding

-- |
-- Type synonym indicating the value should be an octet (0-255). If the value
-- provided is outside this range it will be used as modulo 255.
--
type Octet = Number

-- |
-- Type synonym indicating the value refers to an offset in a buffer.
--
type Offset = Number

-- |
-- An instance of Node's Buffer class.
--
foreign import data Buffer :: *

instance showBuffer :: Show Buffer where
  show = showImpl

foreign import showImpl "var showImpl = require('util').inspect;" :: Buffer -> String

-- |
-- Effect for buffer modification.
--
foreign import data BufferWrite :: !

-- |
-- Enumeration of the numeric types that can be written to a buffer.
--
data BufferValueType
  = UInt8
  | UInt16LE
  | UInt16BE
  | UInt32LE
  | UInt32BE
  | Int8
  | Int16LE
  | Int16BE
  | Int32LE
  | Int32BE
  | FloatLE
  | FloatBE
  | DoubleLE
  | DoubleBE

instance showBufferValueType :: Show BufferValueType where
  show UInt8    = "UInt8"
  show UInt16LE = "UInt16LE"
  show UInt16BE = "UInt16BE"
  show UInt32LE = "UInt32LE"
  show UInt32BE = "UInt32BE"
  show Int8     = "Int8"
  show Int16LE  = "Int16LE"
  show Int16BE  = "Int16BE"
  show Int32LE  = "Int32LE"
  show Int32BE  = "Int32BE"
  show FloatLE  = "FloatLE"
  show FloatBE  = "FloatBE"
  show DoubleLE = "DoubleLE"
  show DoubleBE = "DoubleBE"

-- |
-- Creates a new buffer of the specified size.
--
foreign import create
  "function create (size) { \
  \  return new Buffer(size); \
  \}" :: Number -> Buffer

-- |
-- Creates a new buffer from an array of octets, sized to match the array.
--
foreign import fromArray
  "function fromArray (octets) { \
  \  return new Buffer(octets); \
  \}" :: [Octet] -> Buffer

-- |
-- Creates a new buffer from a string with the specified encoding, sized to
-- match the string.
--
fromString :: String -> Encoding -> Buffer
fromString str = fromStringImpl str <<< show

foreign import fromStringImpl
  "function fromStringImpl (str) { \
  \  return function (encoding) { \
  \    return new Buffer(str, encoding); \
  \  }; \
  \}" :: String -> String -> Buffer

-- |
-- Reads a numeric value from a buffer at the specified offset.
--
read :: BufferValueType -> Offset -> Buffer -> Number
read = readImpl <<< show

foreign import readImpl
  "function readImpl (ty) { \
  \  return function (offset) { \
  \    return function (buf) { \
  \      return buf['read' + ty](offset); \
  \    }; \
  \  }; \
  \}" :: String -> Offset -> Buffer -> Number

-- |
-- Reads a section of a buffer as a string with the specified encoding.
--
readString :: forall e. Encoding -> Offset -> Offset -> Buffer -> String
readString = readStringImpl <<< show

foreign import readStringImpl
  "function readStringImpl (enc) { \
  \  return function (start) { \
  \    return function (end) { \
  \      return function (buff) { \
  \        return buff.toString(enc, start, end); \
  \      } \
  \    } \
  \  } \
  \}":: String -> Offset -> Offset -> Buffer -> String

-- |
-- Reads the buffer as a string with the specified encoding.
--
toString :: forall e. Encoding -> Buffer -> String
toString = toStringImpl <<< show

foreign import toStringImpl
  "function toStringImpl (enc) { \
  \  return function (buff) { \
  \    return buff.toString(enc); \
  \  } \
  \}":: String -> Buffer -> String

-- |
-- Writes a numeric value to a buffer at the specified offset.
--
write :: forall e. BufferValueType -> Number -> Offset -> Buffer -> Eff (buffer :: BufferWrite | e) {}
write = writeImpl <<< show

foreign import writeImpl
  "function writeImpl (ty) { \
  \  return function (value) { \
  \    return function (offset) { \
  \      return function (buf) { \
  \        buf['write' + ty](value, offset); \
  \        return {}; \
  \      }; \
  \    }; \
  \  }; \
  \}" :: forall e. String -> Number -> Offset -> Buffer -> Eff (buffer :: BufferWrite | e) {}

-- |
-- Writes octets from a string to a buffer at the specified offset. Multi-byte
-- characters will not be written to the buffer if there is not enough capacity
-- to write them fully. The number of bytes written is returned.
--
writeString :: forall e. Encoding -> Offset -> Number -> String -> Buffer -> Eff (buffer :: BufferWrite | e) Number
writeString = writeStringImpl <<< show

foreign import writeStringImpl
  "function writeStringImpl (enc) { \
  \  return function (offset) { \
  \      return function (length) { \
  \        return function (value) { \
  \          return function (buff) { \
  \            return buff.write(value, offset, length, encoding); \
  \          }; \
  \        }; \
  \      }; \
  \  }; \
  \}" :: forall e. String -> Offset -> Number -> String -> Buffer -> Eff (buffer :: BufferWrite | e) Number

-- |
-- Creates an array of octets from a buffer's contents.
--
foreign import toArray
  "function toArray (buff) { \
  \  return buff.toJSON(); \
  \}" :: Buffer -> [Octet]

-- |
-- Reads an octet from a buffer at the specified offset.
--
foreign import getAtOffset
  "function getAtOffset (buff) { \
  \  return function (offset) { \
  \    var octet = buff[offset]; \
  \    return octet == null ? _ps.Data_Maybe.Nothing \
  \                         : _ps.Data_Maybe.Just(buff[i]); \
  \  } \
  \}" :: Offset -> Buffer -> Maybe Octet

-- |
-- Writes an octet in the buffer at the specified offset.
--
foreign import setAtOffset
  "function setAtOffset (value) { \
  \  return function (offset) { \
  \    return function (buff) { \
  \      buff[offset] = value; \
  \      return {}; \
  \    } \
  \  } \
  \}" :: forall e. Octet -> Offset -> Buffer -> Eff (buffer :: BufferWrite | e) {}

-- |
-- Returns the size of a buffer.
--
foreign import size
  "function size (buff) { \
  \  return buff.length; \
  \}" :: forall e. Buffer -> Number

-- |
-- Concatenates a list of buffers.
--
foreign import concat
  "function concat (buffs) { \
  \  return Buffer.concat(buffs); \
  \}" :: [Buffer] -> Buffer

-- |
-- Concatenates a list of buffers, combining them into a new buffer of the
-- specified length.
--
foreign import concat'
  "function concat$prime (buffs) { \
  \  return function (totalLength) { \
  \    return Buffer.concat(buffs, totalLength); \
  \  } \
  \}" :: [Buffer] -> Number -> Buffer

-- |
-- Copies a section of a source buffer into a target buffer at the specified
-- offset.
--
foreign import copy
  "function copy (srcStart) { \
  \  return function (srcEnd) { \
  \    return function (src) { \
  \      return function (targStart) { \
  \        return function (targ) { \
  \          return src.copy(targ, targStart, srcStart, strcEnd); \
  \        } \
  \      } \
  \    } \
  \  } \
  \}" :: Offset -> Offset -> Buffer -> Offset -> Buffer -> Buffer

-- |
-- Fills a range in a buffer with the specified octet.
--
foreign import fill
  "function fill (buff) { \
  \  return function (octet) { \
  \    return function (start) { \
  \      return function (end) { \
  \        buff.fill(octet, start, end); \
  \        return {}; \
  \      } \
  \    } \
  \  } \
  \}" :: forall e. Octet -> Offset -> Offset -> Buffer -> Eff (buffer :: BufferWrite | e) {}


export ConnectState constructor

export ConnectState constructor

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

import Prelude

import Control.Monad.Aff (Canceler)
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, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, createClassStateless', 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) (Canceler (redox :: RedoxStore reff | eff))

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

foreign import forceUpdateImpl :: forall eff props state.
  EffFn1 eff (ReactThis props state) Unit

-- | Force render of a react component.
forceUpdate :: forall eff props state.
  ReactThis props state -> Eff eff Unit
forceUpdate this = runEffFn1 forceUpdateImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> Array ReactElement -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    -- using createClassStateless' ensures that children are coerced to `Array ReactElement`
    cls :: ctx -> ReactClass props
    cls ctx = createClassStateless' \props children -> fn props children ctx

    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\props { ctx } -> createElement (cls ctx) props (unsafeCoerce props).children)

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

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> 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 ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

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

    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 ctxEff
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure (ConnectState { state: view _lns 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.
    componentDidMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ ctxEff this
      st@ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      _ <- writeState this (over ConnectState (_ { sid = Just sid }) st)
      state' <- view _lns <$> Redox.getState store
      when
        (runFn2 unsafeStrictEqual state state')
        (forceUpdate this)

    componentWillUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate 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.
      let stateChanged = not $ runFn2 unsafeStrictEqual st.state nSt.state
          propsChanged = not $ runFn3 unsafeShallowEqual true pr nPr
      pure $ stateChanged || propsChanged

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

-- | 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 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.
-- |
-- | 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' reff eff
   . Proxy 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' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    proxy = Proxy

    ctxEff this = _.redox <$> readContext proxy this

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

-- | 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' children { redox: RedoxContext { dispatch: disp }} -> createElement cls (fn disp props') children

-- | Light weight 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 explicitly through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> 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 )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure (RedoxContext {store, dispatch: dispatch_})) _lns _iso cls

-- | If you wrapped your component with `connect` or `connect'` you can use
-- | this `dispatch` function to run your actions.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
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
  , withStore
  , connect'
  , connect
  , withDispatch
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Canceler)
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, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, createClassStateless', 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) (Canceler (redox :: RedoxStore reff | eff))

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

foreign import forceUpdateImpl :: forall eff props state.
  EffFn1 eff (ReactThis props state) Unit

-- | Force render of a react component.
forceUpdate :: forall eff props state.
  ReactThis props state -> Eff eff Unit
forceUpdate this = runEffFn1 forceUpdateImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> Array ReactElement -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    -- using createClassStateless' ensures that children are coerced to `Array ReactElement`
    cls :: ctx -> ReactClass props
    cls ctx = createClassStateless' \props children -> fn props children ctx

    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\props { ctx } -> createElement (cls ctx) props (unsafeCoerce props).children)

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

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> 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 ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentDidMount = componentDidMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

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

    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 ctxEff
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure (ConnectState { state: view _lns 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.
    componentDidMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ ctxEff this
      st@ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      _ <- writeState this (over ConnectState (_ { sid = Just sid }) st)
      state' <- view _lns <$> Redox.getState store
      when
        (runFn2 unsafeStrictEqual state state')
        (forceUpdate this)

    componentWillUnmount this = do
      writeIsMounted this false
      RedoxContext ctx <- unsafeCoerceEff $ ctxEff this
      ConnectState { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate 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.
      let stateChanged = not $ runFn2 unsafeStrictEqual st.state nSt.state
          propsChanged = not $ runFn3 unsafeShallowEqual true pr nPr
      pure $ stateChanged || propsChanged

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

-- | 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 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.
-- |
-- | 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' reff eff
   . Proxy 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' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    proxy = Proxy

    ctxEff this = _.redox <$> readContext proxy this

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

-- | 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' children { redox: RedoxContext { dispatch: disp }} -> createElement cls (fn disp props') children

-- | Light weight 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 explicitly through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> 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 )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure (RedoxContext {store, dispatch: dispatch_})) _lns _iso cls

-- | If you wrapped your component with `connect` or `connect'` you can use
-- | this `dispatch` function to run your actions.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
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