Main.purs

module Main where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.ST.Class (class MonadST, liftST)
import Control.Monad.ST.Ref (new, modify, read)
import Data.Array (cons, fromFoldable)
import Data.Foldable (class Foldable, for_, traverse_)
import Data.Foldable as Foldable
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.String (joinWith)
import Data.String.CodeUnits (charAt, singleton)
import Data.Traversable (sequence)
import Deku.Attribute (cb, (:=))
import Deku.Control (text, text_)
import Deku.Core (class Korok, Domable, Nut, bus, bussed, dyn, insert, remove)
import Deku.DOM as D
import Deku.Listeners as DL
import Deku.Toplevel (runInBody1)
import Effect (Effect)
import FRP.Event (AnEvent, bang, fold, keepLatest, makeEvent, subscribe)
import FRP.Event.Class (biSampleOn)
import Web.Event.Event (target)
import Web.HTML.HTMLInputElement (fromEventTarget, value)

main :: Effect Unit
main = runInBody1 (
    (\pe ->
      D.div_
        [ page pe
        , D.div_
          [ text_ "Current Models: "
          , text $ (joinWith "," <<< fromFoldable <<< Map.keys) <$> pe.modelsForParentEv
          ]
        , D.div_
          [ text_ "combined emissions of Sources:"
          , text $ keepLatest $ combinedEmissions <$> pe.modelsForParentEv
          ]
        ]
    ) <$> createPropagatedEv
  )

combinedEmissions :: ∀ s m. MonadST s m => Applicative m => ModelsForParent m -> AnEvent m String
combinedEmissions models = combineFold (<>) " " $ map (_.ev) $ Map.values models

type ModelsForParent m = Map String {label :: String, ev :: AnEvent m String}

-- | Has both IO for internal operation of `page` as well as API for `page`'s parents to observe.
-- | As discussed on discord I need to pass these IO bits in (instead of returning them), right?
type PageContext m =
  -- / These are only used internally by `page`
  { uiActionPush :: (UIAction -> Effect Unit)
  , rowModelEv :: AnEvent m (RowModel m)
  -- / This is the exposed API for the parent to consume
  , modelsForParentEv :: AnEvent m (ModelsForParent m)
  }

type RowModel m =
  { label :: String
  , rowDeletePush :: String -> Effect Unit
  , rowDeleteEv :: AnEvent m String
  , rowEmitPush :: String -> Effect Unit
  , rowEmitEv :: AnEvent m String
  }

data UIAction = PlusClick

-- Basic PS q: Is there a way to make this private or internal to the function that it is being used?
data StoreAction m = Delete String | Add (RowModel m)

page :: ∀ s m l p. Korok s m => PageContext m -> Domable m l p
page {uiActionPush, rowModelEv} =
        D.div_
          [ D.div_ [dyn $ mkRow <$> rowModelEv]
          , D.div_
            [ text_ "Add Source:"
            , D.button (DL.click $ bang (uiActionPush PlusClick)) [text_ "+"]
            ]
          ]

  where
  mkRow :: RowModel m -> _
  mkRow {label, rowDeletePush, rowDeleteEv, rowEmitPush} =
    let
        onClickEmit inputText = rowEmitPush inputText
        rowDiv = D.div_ [upstreamSourceRow label onClickEmit (rowDeletePush label)]
    in
    (bang $ insert rowDiv) <|> (const remove <$> rowDeleteEv)

  upstreamSourceRow :: String -> (String -> Effect Unit) -> Effect Unit -> Nut
  upstreamSourceRow label onEmitClick onDelete = bussed \pushText textEv ->
    D.div_
      [ text_ $ "Source " <> label
      , D.button (DL.click $ bang onDelete) [ text_ "-" ]
      , D.input (
          bang $ D.OnInput := cb \e -> for_
                                ( target e >>= fromEventTarget)
                                ( value >=> pushText)
        ) []
      , D.button (DL.click $ map onEmitClick textEv) [ text_ "Emit->" ]
      ]

-- / Helper function that the `page`'s Parent can use to create the PageContext. The goal is to try
-- / to abstract as much logic from the Parent as possible.
createPropagatedEv :: ∀ s m. Korok s m => AnEvent m (PageContext m)
createPropagatedEv = bus \uiActionPush uiActionEv ->
  let
      emit1OnPlusClick :: AnEvent m Int
      emit1OnPlusClick = const 1 <$> uiActionEv

      incrStart2 :: AnEvent m Int
      incrStart2 = bang 0 <|> bang 1 <|> (fold (+) emit1OnPlusClick 1)

      labelEv :: AnEvent m String
      labelEv = mkLabel <$> incrStart2

      rowModelEv :: AnEvent m (RowModel m)
      rowModelEv = keepLatest (mkRowModel <$> labelEv)

      modelsForParentEv :: AnEvent m (ModelsForParent m)
      modelsForParentEv =
        let
            deleteEv :: AnEvent m (StoreAction m)
            deleteEv = Delete <$> flatMap ((_.rowDeleteEv) <$> rowModelEv)

            addEv :: AnEvent m (StoreAction m)
            addEv = Add <$> rowModelEv

            storeEvReduce :: StoreAction m -> ModelsForParent m -> ModelsForParent m
            storeEvReduce (Delete label) store = Map.delete label store
            storeEvReduce (Add {label, rowEmitEv}) store =
              Map.insert label {label, ev: rowEmitEv} store
        in
        fold storeEvReduce (addEv <|> deleteEv) Map.empty
  in
  {uiActionPush, rowModelEv, modelsForParentEv}
  where
  mkRowModel :: String -> AnEvent m (RowModel m)
  mkRowModel label = keepLatest $
    bus \rowDeletePush rowDeleteEv ->
      bus \rowEmitPush rowEmitEv ->
        {label, rowDeletePush, rowDeleteEv, rowEmitPush, rowEmitEv}

  mkLabel i = singleton <<< fromMaybe '_' $ charAt i "abcdefghijlmnopqrstuvxz"



-- From Paraglider
flatMap :: forall s m a. MonadST s m => AnEvent m (AnEvent m a) -> AnEvent m a
flatMap ee = makeEvent \k -> do
  us <- liftST $ new []
  u <- subscribe ee \e -> do
    u' <- subscribe e k
    void $ liftST $ modify (cons u') us
  pure do
    u
    liftST (read us) >>= traverse_ identity

-- From Paraglider
combineFold
  :: ∀ a b f m s
   . MonadST s m
  => Foldable f
  => (a -> b -> b)
  -> b
  -> f (AnEvent m a)
  -> AnEvent m b
combineFold f initial xs =
  let
      mapper :: AnEvent m b -> AnEvent m a -> AnEvent m b
      mapper = \accEvent ev -> biSampleOn accEvent $ f <$> ev
  in
  Foldable.foldl (mapper) (bang initial) xs