UIwithWander.purs

module OpticUI.Core
  ( UI ()
  , Handler (..)
  , runHandler
  , runUI
  , ui
  , with
  , withView
  , foreach
  , inline
  ) where
--------------------------------------------------------------------------------
import           Prelude
import           Data.Profunctor            (Profunctor, dimap)
import           Data.Profunctor.Choice     (Choice, left, right)
import           Data.Profunctor.Strong     (Strong, first, second)
import           Control.Monad.State
import           Control.Monad.State.Class
import           Control.Monad.Eff          (Eff ())
import           Data.Monoid                (Monoid, mempty)
import           Data.Lens
import           Data.Lens.Internal.Wander
import           Data.Profunctor.Star
import           Data.Traversable           (Traversable, traverse, sequence)
import           Data.Tuple                 (Tuple (..))
import           Data.Either                (Either (..), either)
import           Data.Functor.Contravariant (Contravariant, cmap)
--------------------------------------------------------------------------------

newtype UI eff v s t = UI (s -> Sink eff v t)

instance uiProfunctor :: Profunctor (UI eff v) where
  dimap f g (UI u) = UI $ map g <<< u <<< f

instance uiStrong :: Strong (UI eff v) where
  first (UI u) = UI \(Tuple a c) -> map (`Tuple` c) (u a)
  second (UI u) = UI \(Tuple c a) -> map (Tuple c) (u a)

instance uiChoice :: (Monoid v) => Choice (UI m v) where
  left (UI u) = UI $ either (map Left <<< u) (pure <<< Right)
  right (UI u) = UI $ either (pure <<< Left) (map Right <<< u)

instance uiWander :: (Monoid v) => Wander (UI m v) where
  wander tr = UI <<< tr <<< toSink

instance uiSemigroup :: (Semigroup v) => Semigroup (UI eff v a a) where
  append (UI u) (UI v) = UI \s -> Sink s \h -> (<>) <$> runSink (u s) h <*> runSink (v s) h

instance uiMonoid :: (Monoid v) => Monoid (UI eff v a a) where
  mempty = UI pure

runUI :: forall eff v s t. UI eff v s t -> s -> Handler eff t -> Eff eff v
runUI (UI u) s = runSink (u s)

--------------------------------------------------------------------------------

newtype Handler eff s = Handler (s -> Eff eff Unit)

instance handlerContravariant :: Contravariant (Handler eff) where
  cmap f (Handler h) = Handler (h <<< f)

runHandler :: forall eff s. Handler eff s -> s -> Eff eff Unit
runHandler (Handler h) = h

--------------------------------------------------------------------------------

-- | Create a static `UI` component from a view.
ui :: forall eff v s. v -> UI eff v s s
ui v = UI \s -> Sink s (const $ pure v)

-- | Access the state and the handler for an `UI` component.
with :: forall eff v s. (s -> Handler eff s -> UI eff v s s) -> UI eff v s s
with f = UI \s -> Sink s \h -> case f s h of UI u -> runSink (u s) h

-- | Manipulate the view of an `UI` component.
withView :: forall eff v w s t. (v -> w) -> UI eff v s t -> UI eff w s t
withView f (UI u) = UI \s -> case u s of Sink t z -> Sink t (map f <<< z)

-- | Display a `UI` component for each element of a `Traversable` container,
-- | with access to the index into the container.
foreach
  :: forall eff v s t. (Monoid v, Traversable t)
  => (Int -> UI eff v s s) -> UI eff v (t s) (t s)
foreach f = UI $ sequence <<< indices (toSink <<< f) where
  indices g t = evalState (traverse (\x -> state \i -> Tuple (g i x) (i + 1)) t) 0

-- | Create a `UI` component that executes an action while build.
inline :: forall eff v s. Eff eff v -> UI eff v s s
inline go = UI \s -> Sink s (const go)

--------------------------------------------------------------------------------

data Sink eff v a = Sink a (Handler eff a -> Eff eff v)

instance sinkFunctor :: Functor (Sink eff v) where
  map f (Sink a z) = Sink (f a) (z <<< cmap f)

instance sinkApply :: (Semigroup v) => Apply (Sink eff v) where
  apply (Sink tf zf) (Sink tx zx) = Sink (tf tx)
    \h -> (<>) <$> zf (cmap ($ tx) h) <*> zx (cmap tf h)

instance sinkApplicative :: (Monoid v) => Applicative (Sink eff v) where
  pure x = Sink x (const $ pure mempty)

runSink :: forall eff v a. Sink eff v a -> Handler eff a -> Eff eff v
runSink (Sink _ z) h = z h

toSink :: forall eff v a b. UI eff v a b -> a -> Sink eff v b
toSink (UI u) a = u a