-----------------------------------------------------------------------------
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE RankNTypes                 #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Binding
-- Copyright   :  (C) 2016-2026 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- = Data Bindings
--
-- miso includes an experimental feature that allows fields of different models to be synchronized
-- against each another in response to model changes. See 'Miso.Binding'. Note this feature is
-- experimental, it is recommended to use asynchronous Component communication (like 'broadcast') by default.
--
-- This module exposes combinators to construct a 'Binding' which holds two lenses that will alter
-- t'Component' model state along the parent-child relationship using a 'Lens'. Practically, this means when
-- one t'Component' is marked as dirty, another t'Component' will also potentially will be marked as
-- dirty if they are connected along an edge ('Binding').
--
-- See the [miso-reactive](https://github.com/haskell-miso/miso-reactive) project for more information.
--
----------------------------------------------------------------------------
module Miso.Binding
  ( -- ** Types
    Binding (..)
  , Precedence (..)
    -- ** Combinators
  , (<-->)
  , (<<-->)
  , (<-->>)
  , (<--)
  , (-->)
  , (<--->)
  , (<<--->)
  , (<--->>)
  , (<---)
  , (--->)
  ) where
----------------------------------------------------------------------------
import Data.Functor.Const (Const(..))
import Control.Monad.Identity (Identity(..))
----------------------------------------------------------------------------
import Miso.Lens (Lens, Lens', LensCore(..))
----------------------------------------------------------------------------
-- | t'Binding' is used to synchronize parent and child model changes at the granularity specified by a t'Miso.Lens.Lens'
--
-- This can be thought of as establishing an "edge" in the 'Miso.Types.Component' graph,
-- whereby events cause model change synchronization to "ripple" or "pulsate"
-- through the views. The "reactivity" of the graph is constructed manually
-- by the end-user, using the edge primitives `-->`, `<--`, `<-->` (reactive combinators).
--
-- @
-- main :: IO ()
-- main = run app { bindings = [ parentLens \<--\> childLens ] }
-- @
--
-- @since 1.9.0.0
data Binding parent child
  = forall field . ParentToChild (parent -> field) (field -> child -> child)
  | forall field . ChildToParent (field -> parent -> parent) (child -> field)
  | forall field . Bidirectional Precedence (parent -> field) (field -> parent -> parent) (child -> field) (field -> child -> child)
-----------------------------------------------------------------------------
-- | Data type used to express if the Child state should take precendence
-- over the parent state during 'Component' mount.
data Precedence = Child | Parent
  deriving (Precedence -> Precedence -> Bool
(Precedence -> Precedence -> Bool)
-> (Precedence -> Precedence -> Bool) -> Eq Precedence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Precedence -> Precedence -> Bool
== :: Precedence -> Precedence -> Bool
$c/= :: Precedence -> Precedence -> Bool
/= :: Precedence -> Precedence -> Bool
Eq, Int -> Precedence -> ShowS
[Precedence] -> ShowS
Precedence -> String
(Int -> Precedence -> ShowS)
-> (Precedence -> String)
-> ([Precedence] -> ShowS)
-> Show Precedence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Precedence -> ShowS
showsPrec :: Int -> Precedence -> ShowS
$cshow :: Precedence -> String
show :: Precedence -> String
$cshowList :: [Precedence] -> ShowS
showList :: [Precedence] -> ShowS
Show)
-----------------------------------------------------------------------------
-- | Unidirectionally binds a parent field to a child field
--
-- @since 1.9.0.0
infixr 0 -->
(-->) :: Lens parent a -> Lens model a -> Binding parent model
Lens parent a
parent --> :: forall parent a model.
Lens parent a -> Lens model a -> Binding parent model
--> Lens model a
child = (parent -> a) -> (a -> model -> model) -> Binding parent model
forall parent child field.
(parent -> field)
-> (field -> child -> child) -> Binding parent child
ParentToChild (Lens parent a -> parent -> a
forall field record. LensCore field record -> record -> field
_get Lens parent a
parent) (Lens model a -> a -> model -> model
forall field record.
LensCore field record -> field -> record -> record
_set Lens model a
child)
-----------------------------------------------------------------------------
-- | Unidirectionally binds a child field to a parent field
--
-- @since 1.9.0.0
infixl 0 <--
(<--) :: Lens parent a  -> Lens model a -> Binding parent model
Lens parent a
parent <-- :: forall parent a model.
Lens parent a -> Lens model a -> Binding parent model
<-- Lens model a
child = (a -> parent -> parent) -> (model -> a) -> Binding parent model
forall parent child field.
(field -> parent -> parent)
-> (child -> field) -> Binding parent child
ChildToParent (Lens parent a -> a -> parent -> parent
forall field record.
LensCore field record -> field -> record -> record
_set Lens parent a
parent) (Lens model a -> model -> a
forall field record. LensCore field record -> record -> field
_get Lens model a
child)
-----------------------------------------------------------------------------
-- | Bidirectionally binds a child field to a parent field, using @Lens@
--
-- This is a bidirectional reactive combinator for a miso @Lens@.
--
-- @since 1.9.0.0
infix 0 <-->
(<-->) :: Lens parent field -> Lens child field -> Binding parent child
Lens parent field
p <--> :: forall parent a model.
Lens parent a -> Lens model a -> Binding parent model
<--> Lens child field
c = Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
forall parent child field.
Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
Bidirectional Precedence
Parent (Lens parent field -> parent -> field
forall field record. LensCore field record -> record -> field
_get Lens parent field
p) (Lens parent field -> field -> parent -> parent
forall field record.
LensCore field record -> field -> record -> record
_set Lens parent field
p) (Lens child field -> child -> field
forall field record. LensCore field record -> record -> field
_get Lens child field
c) (Lens child field -> field -> child -> child
forall field record.
LensCore field record -> field -> record -> record
_set Lens child field
c)
-----------------------------------------------------------------------------
-- | Bidirectionally binds a child field to a parent field, using @Lens'@
--
-- This is a bidirectional reactive combinator for a van Laarhoven @Lens'@
--
-- @since 1.9.0.0
infix 0 <--->
(<--->) :: Lens' parent field -> Lens' child field -> Binding parent child
Lens' parent field
p <---> :: forall parent field child.
Lens' parent field -> Lens' child field -> Binding parent child
<---> Lens' child field
c = Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
forall parent child field.
Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
Bidirectional Precedence
Parent (((field -> Const field field) -> parent -> Const field parent)
-> parent -> field
forall {a} {b} {t} {a} {b}.
((a -> Const a b) -> t -> Const a b) -> t -> a
get_ (field -> Const field field) -> parent -> Const field parent
Lens' parent field
p) (((field -> Identity field) -> parent -> Identity parent)
-> field -> parent -> parent
forall {t} {a} {a} {c}.
((t -> Identity a) -> a -> Identity c) -> a -> a -> c
set_ (field -> Identity field) -> parent -> Identity parent
Lens' parent field
p) (((field -> Const field field) -> child -> Const field child)
-> child -> field
forall {a} {b} {t} {a} {b}.
((a -> Const a b) -> t -> Const a b) -> t -> a
get_ (field -> Const field field) -> child -> Const field child
Lens' child field
c) (((field -> Identity field) -> child -> Identity child)
-> field -> child -> child
forall {t} {a} {a} {c}.
((t -> Identity a) -> a -> Identity c) -> a -> a -> c
set_ (field -> Identity field) -> child -> Identity child
Lens' child field
c)
  where
    get_ :: ((a -> Const a b) -> t -> Const a b) -> t -> a
get_ (a -> Const a b) -> t -> Const a b
lens_ t
record = Const a b -> a
forall {k} a (b :: k). Const a b -> a
getConst ((a -> Const a b) -> t -> Const a b
lens_ a -> Const a b
forall {k} a (b :: k). a -> Const a b
Const t
record)
    set_ :: ((t -> Identity a) -> a -> Identity c) -> a -> a -> c
set_ (t -> Identity a) -> a -> Identity c
lens_ a
field = Identity c -> c
forall a. Identity a -> a
runIdentity (Identity c -> c) -> (a -> Identity c) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> Identity a) -> a -> Identity c
lens_ (\t
_ -> a -> Identity a
forall a. a -> Identity a
Identity a
field)
-----------------------------------------------------------------------------
-- | Like '<--->' but biases to inherit 'Parent' state on 'Component' 'mount'.
--
-- @since 1.10.0.0
(<--->>)
  :: Lens' parent field
  -> Lens' child field
  -> Binding parent child
Lens' parent field
l <--->> :: forall parent field child.
Lens' parent field -> Lens' child field -> Binding parent child
<--->> Lens' child field
r =
  case (field -> f field) -> parent -> f parent
Lens' parent field
l Lens' parent field -> Lens' child field -> Binding parent child
forall parent field child.
Lens' parent field -> Lens' child field -> Binding parent child
<---> (field -> f field) -> child -> f child
Lens' child field
r of
    Bidirectional Precedence
_ parent -> field
w field -> parent -> parent
x child -> field
y field -> child -> child
z -> Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
forall parent child field.
Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
Bidirectional Precedence
Parent parent -> field
w field -> parent -> parent
x child -> field
y field -> child -> child
z
    Binding parent child
_ -> String -> Binding parent child
forall a. HasCallStack => String -> a
error String
"impossible"
-----------------------------------------------------------------------------
-- | Like '<--->' but biases to inherit 'Child' state on 'Component' 'mount'.
--
-- @since 1.10.0.0
(<<--->)
  :: Lens' parent field
  -> Lens' child field
  -> Binding parent child
Lens' parent field
l <<---> :: forall parent field child.
Lens' parent field -> Lens' child field -> Binding parent child
<<---> Lens' child field
r =
  case (field -> f field) -> parent -> f parent
Lens' parent field
l Lens' parent field -> Lens' child field -> Binding parent child
forall parent field child.
Lens' parent field -> Lens' child field -> Binding parent child
<---> (field -> f field) -> child -> f child
Lens' child field
r of
    Bidirectional Precedence
_ parent -> field
w field -> parent -> parent
x child -> field
y field -> child -> child
z -> Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
forall parent child field.
Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
Bidirectional Precedence
Child parent -> field
w field -> parent -> parent
x child -> field
y field -> child -> child
z
    Binding parent child
_ -> String -> Binding parent child
forall a. HasCallStack => String -> a
error String
"impossible"
-----------------------------------------------------------------------------
-- | Unidirectionally binds a parent field to a child field, for van Laarhoven
-- style @Lens'@
--
-- @since 1.9.0.0
infixr 0 --->
(--->) :: Lens' parent field -> Lens' child field -> Binding parent child
Lens' parent field
p ---> :: forall parent field child.
Lens' parent field -> Lens' child field -> Binding parent child
---> Lens' child field
c = (parent -> field)
-> (field -> child -> child) -> Binding parent child
forall parent child field.
(parent -> field)
-> (field -> child -> child) -> Binding parent child
ParentToChild (((field -> Const field field) -> parent -> Const field parent)
-> parent -> field
forall {a} {b} {t} {a} {b}.
((a -> Const a b) -> t -> Const a b) -> t -> a
get_ (field -> Const field field) -> parent -> Const field parent
Lens' parent field
p) (((field -> Identity field) -> child -> Identity child)
-> field -> child -> child
forall {t} {a} {a} {c}.
((t -> Identity a) -> a -> Identity c) -> a -> a -> c
set_ (field -> Identity field) -> child -> Identity child
Lens' child field
c)
  where
    get_ :: ((a -> Const a b) -> t -> Const a b) -> t -> a
get_ (a -> Const a b) -> t -> Const a b
lens_ t
record = Const a b -> a
forall {k} a (b :: k). Const a b -> a
getConst ((a -> Const a b) -> t -> Const a b
lens_ a -> Const a b
forall {k} a (b :: k). a -> Const a b
Const t
record)
    set_ :: ((t -> Identity a) -> a -> Identity c) -> a -> a -> c
set_ (t -> Identity a) -> a -> Identity c
lens_ a
field = Identity c -> c
forall a. Identity a -> a
runIdentity (Identity c -> c) -> (a -> Identity c) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> Identity a) -> a -> Identity c
lens_ (\t
_ -> a -> Identity a
forall a. a -> Identity a
Identity a
field)
-----------------------------------------------------------------------------
-- | Like '<-->' but biases to inherit 'Parent' state on 'Component' 'mount'.
--
-- @since 1.10.0.0
(<-->>)
  :: Lens parent field
  -> Lens child field
  -> Binding parent child
Lens parent field
l <-->> :: forall parent a model.
Lens parent a -> Lens model a -> Binding parent model
<-->> Lens child field
r =
  case Lens parent field
l Lens parent field -> Lens child field -> Binding parent child
forall parent a model.
Lens parent a -> Lens model a -> Binding parent model
<--> Lens child field
r of
    Bidirectional Precedence
_ parent -> field
w field -> parent -> parent
x child -> field
y field -> child -> child
z -> Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
forall parent child field.
Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
Bidirectional Precedence
Parent parent -> field
w field -> parent -> parent
x child -> field
y field -> child -> child
z
    Binding parent child
_ -> String -> Binding parent child
forall a. HasCallStack => String -> a
error String
"impossible"
-----------------------------------------------------------------------------
-- | Like '<-->' but biases to inherit 'Child' state on 'Component' 'mount'.
--
-- @since 1.10.0.0
(<<-->)
  :: Lens parent field
  -> Lens child field
  -> Binding parent child
Lens parent field
l <<--> :: forall parent a model.
Lens parent a -> Lens model a -> Binding parent model
<<--> Lens child field
r =
  case Lens parent field
l Lens parent field -> Lens child field -> Binding parent child
forall parent a model.
Lens parent a -> Lens model a -> Binding parent model
<--> Lens child field
r of
    Bidirectional Precedence
_ parent -> field
w field -> parent -> parent
x child -> field
y field -> child -> child
z -> Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
forall parent child field.
Precedence
-> (parent -> field)
-> (field -> parent -> parent)
-> (child -> field)
-> (field -> child -> child)
-> Binding parent child
Bidirectional Precedence
Child parent -> field
w field -> parent -> parent
x child -> field
y field -> child -> child
z
    Binding parent child
_ -> String -> Binding parent child
forall a. HasCallStack => String -> a
error String
"impossible"
-----------------------------------------------------------------------------
-- | Unidirectionally binds a child field to a parent field, for van Laarhoven
-- style @Lens'@
--
-- @since 1.9.0.0
infixl 0 <---
(<---) :: Lens' parent field -> Lens' child field -> Binding parent child
Lens' parent field
p <--- :: forall parent field child.
Lens' parent field -> Lens' child field -> Binding parent child
<--- Lens' child field
c = (field -> parent -> parent)
-> (child -> field) -> Binding parent child
forall parent child field.
(field -> parent -> parent)
-> (child -> field) -> Binding parent child
ChildToParent (((field -> Identity field) -> parent -> Identity parent)
-> field -> parent -> parent
forall {t} {a} {a} {c}.
((t -> Identity a) -> a -> Identity c) -> a -> a -> c
set_ (field -> Identity field) -> parent -> Identity parent
Lens' parent field
p) (((field -> Const field field) -> child -> Const field child)
-> child -> field
forall {a} {b} {t} {a} {b}.
((a -> Const a b) -> t -> Const a b) -> t -> a
get_ (field -> Const field field) -> child -> Const field child
Lens' child field
c)
  where
    get_ :: ((a -> Const a b) -> t -> Const a b) -> t -> a
get_ (a -> Const a b) -> t -> Const a b
lens_ t
record = Const a b -> a
forall {k} a (b :: k). Const a b -> a
getConst ((a -> Const a b) -> t -> Const a b
lens_ a -> Const a b
forall {k} a (b :: k). a -> Const a b
Const t
record)
    set_ :: ((t -> Identity a) -> a -> Identity c) -> a -> a -> c
set_ (t -> Identity a) -> a -> Identity c
lens_ a
field = Identity c -> c
forall a. Identity a -> a
runIdentity (Identity c -> c) -> (a -> Identity c) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> Identity a) -> a -> Identity c
lens_ (\t
_ -> a -> Identity a
forall a. a -> Identity a
Identity a
field)
-----------------------------------------------------------------------------