-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Flow
-- License     :  BSD3-style (see the file LICENSE)
--
-- Node-based UIs for miso, powered by xyflow. This module wraps the
-- pure ports ("Miso.Flow.Types", "Miso.Flow.Utils"), the view layer
-- ("Miso.Flow.View") and the JavaScript gesture bridge
-- ("Miso.Flow.Internal.Bridge") into an MVU component:
--
-- @
-- main :: IO ()
-- main = startApp defaultEvents $
--   flowComponent defaultStoreOptions (text . nodeLabel) id myNodes myEdges
-- @
--
-- Requires @js\/miso-flow.js@ (it defines @globalThis.MisoFlow@); it
-- ships inside the compiled output (@js-sources@ on the GHCJS\/JS
-- backends, a compile-time splice on WASM).
----------------------------------------------------------------------------
module Miso.Flow
  ( -- * Component
    flowComponent
    -- * Settings
  , FlowSettings (..)
  , defaultFlowSettings
    -- * Model
  , FlowModel
  , flowModel
  , flowNodes
  , flowEdges
  , flowViewport
  , flowConnection
  , flowOptions
    -- * Actions
  , FlowAction (..)
    -- * Update \/ view (for manual embedding)
  , updateFlow
  , updateFlowWith
  , viewFlow
  , flowHooks
  , sceneFromModel
    -- * Re-exports
  , StoreOptions (..)
  , defaultStoreOptions
  , module Miso.Flow.Types
  , module Miso.Flow.View
  , flowCSS
  , flowStyles
  , flowBaseCSS
  , flowBaseStyles
  , flowThemeCSS
  , flowThemeStyles
  ) where
-----------------------------------------------------------------------------
import           Control.Monad (unless, when)
import qualified Data.Map.Strict as M
import           Data.Maybe (fromMaybe)
import qualified Data.Set as S
import           Prelude
-----------------------------------------------------------------------------
import           Miso.Effect (DOMRef, Effect, io_, withSink)
import           Miso.JSON (Value, object, (.=))
import           Miso.State (get, modify, put)
import           Miso.String (MisoString)
import           Miso.Types (Component (..), View, component)
-----------------------------------------------------------------------------
import           Miso.Flow.Constants (infiniteExtent)
import           Miso.Flow.Internal.Bridge
import           Miso.Flow.Style
  ( flowBaseCSS
  , flowBaseStyles
  , flowCSS
  , flowStyles
  , flowThemeCSS
  , flowThemeStyles
  )
import           Miso.Flow.Types
import           Miso.Flow.Utils.Edges (addEdge, reconnectEdge)
import           Miso.Flow.Utils.General (pointToRendererPoint)
import           Miso.Flow.Utils.Graph (getElementsToRemove, getNodesInside)
import           Miso.Flow.Utils.Store
  ( UpdateNodesOptions (..)
  , NodeMeasurement (..)
  , adoptUserNodes
  , applyMeasurement
  , defaultUpdateNodesOptions
  )
import           Miso.Flow.View
-----------------------------------------------------------------------------
-- | Attach work that arrived before the JavaScript store existed
-- (lifecycle hooks fire in creation order, so node \/ handle elements
-- can report in before 'FlowStoreCreated' lands). Never rendered.
data PendingAttach = PendingAttach
  { PendingAttach -> [(MisoString, DOMRef)]
pendingNodes    :: [(NodeId, DOMRef)]
  , PendingAttach -> [DOMRef]
pendingHandles  :: [DOMRef]
  , PendingAttach -> [(MisoString, Value, DOMRef)]
pendingResizers :: [(NodeId, Value, DOMRef)]
  , PendingAttach -> [(MinimapConfig, DOMRef)]
pendingMinimaps :: [(MinimapConfig, DOMRef)]
  }
-----------------------------------------------------------------------------
-- | 'DOMRef's have no 'Eq'; compare by what accumulated instead. The
-- runtime only commits a model that differs from the previous one, so
-- queueing must register as a change. Pending only ever grows until the
-- store arrives (afterwards elements attach directly), so node ids plus
-- the handle count identify the queue.
instance Eq PendingAttach where
  PendingAttach [(MisoString, DOMRef)]
ns [DOMRef]
hs [(MisoString, Value, DOMRef)]
rs [(MinimapConfig, DOMRef)]
ms == :: PendingAttach -> PendingAttach -> Bool
== PendingAttach [(MisoString, DOMRef)]
ns' [DOMRef]
hs' [(MisoString, Value, DOMRef)]
rs' [(MinimapConfig, DOMRef)]
ms' =
    ((MisoString, DOMRef) -> MisoString)
-> [(MisoString, DOMRef)] -> [MisoString]
forall a b. (a -> b) -> [a] -> [b]
map (MisoString, DOMRef) -> MisoString
forall a b. (a, b) -> a
fst [(MisoString, DOMRef)]
ns [MisoString] -> [MisoString] -> Bool
forall a. Eq a => a -> a -> Bool
== ((MisoString, DOMRef) -> MisoString)
-> [(MisoString, DOMRef)] -> [MisoString]
forall a b. (a -> b) -> [a] -> [b]
map (MisoString, DOMRef) -> MisoString
forall a b. (a, b) -> a
fst [(MisoString, DOMRef)]
ns'
      Bool -> Bool -> Bool
&& [DOMRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DOMRef]
hs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [DOMRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DOMRef]
hs'
      Bool -> Bool -> Bool
&& ((MisoString, Value, DOMRef) -> (MisoString, Value))
-> [(MisoString, Value, DOMRef)] -> [(MisoString, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\(MisoString
i, Value
v, DOMRef
_) -> (MisoString
i, Value
v)) [(MisoString, Value, DOMRef)]
rs [(MisoString, Value)] -> [(MisoString, Value)] -> Bool
forall a. Eq a => a -> a -> Bool
== ((MisoString, Value, DOMRef) -> (MisoString, Value))
-> [(MisoString, Value, DOMRef)] -> [(MisoString, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\(MisoString
i, Value
v, DOMRef
_) -> (MisoString
i, Value
v)) [(MisoString, Value, DOMRef)]
rs'
      Bool -> Bool -> Bool
&& ((MinimapConfig, DOMRef) -> MinimapConfig)
-> [(MinimapConfig, DOMRef)] -> [MinimapConfig]
forall a b. (a -> b) -> [a] -> [b]
map (\(MinimapConfig
c, DOMRef
_) -> MinimapConfig
c) [(MinimapConfig, DOMRef)]
ms [MinimapConfig] -> [MinimapConfig] -> Bool
forall a. Eq a => a -> a -> Bool
== ((MinimapConfig, DOMRef) -> MinimapConfig)
-> [(MinimapConfig, DOMRef)] -> [MinimapConfig]
forall a b. (a -> b) -> [a] -> [b]
map (\(MinimapConfig
c, DOMRef
_) -> MinimapConfig
c) [(MinimapConfig, DOMRef)]
ms'
-----------------------------------------------------------------------------
noPending :: PendingAttach
noPending :: PendingAttach
noPending = [(MisoString, DOMRef)]
-> [DOMRef]
-> [(MisoString, Value, DOMRef)]
-> [(MinimapConfig, DOMRef)]
-> PendingAttach
PendingAttach [] [] [] []
-----------------------------------------------------------------------------
-- | Behavioral settings that cannot live in the (JSON-serialized)
-- 'StoreOptions' or the ('Eq'-constrained) model.
newtype FlowSettings = FlowSettings
  { FlowSettings -> Maybe (Connection -> Bool)
fsValidateConnection :: Maybe (Connection -> Bool)
    -- ^ consulted synchronously by the gesture system while a
    -- connection (or reconnection) is dragged; invalid targets render
    -- the connection line in the invalid style and refuse to connect
  }
-----------------------------------------------------------------------------
defaultFlowSettings :: FlowSettings
defaultFlowSettings :: FlowSettings
defaultFlowSettings = FlowSettings
  { fsValidateConnection :: Maybe (Connection -> Bool)
fsValidateConnection = Maybe (Connection -> Bool)
forall a. Maybe a
Nothing
  }
-----------------------------------------------------------------------------
-- | State of one flow: the user graph, its computed internals, and the
-- handle to the JavaScript store.
data FlowModel n e = FlowModel
  { forall n e. FlowModel n e -> [Node n]
fmNodes        :: [Node n]
  , forall n e. FlowModel n e -> [Edge e]
fmEdges        :: [Edge e]
  , forall n e. FlowModel n e -> NodeLookup n
fmNodeLookup   :: NodeLookup n
  , forall n e. FlowModel n e -> ParentLookup n
fmParentLookup :: ParentLookup n
  , forall n e. FlowModel n e -> Viewport
fmViewport     :: Viewport
  , forall n e. FlowModel n e -> ConnectionState n
fmConnection   :: ConnectionState n
  , forall n e. FlowModel n e -> Maybe FlowStore
fmStore        :: Maybe FlowStore
  , forall n e. FlowModel n e -> PendingAttach
fmPending      :: PendingAttach
  , forall n e. FlowModel n e -> StoreOptions
fmOptions      :: StoreOptions
  , forall n e. FlowModel n e -> Dimensions
fmDimensions   :: Dimensions
  , forall n e. FlowModel n e -> Maybe MinimapConfig
fmMinimap      :: Maybe MinimapConfig
    -- ^ set once a 'minimapView' reports in
  , forall n e. FlowModel n e -> Maybe Rect
fmSelectionRect :: Maybe Rect
    -- ^ in-progress selection box (container coordinates)
  } deriving FlowModel n e -> FlowModel n e -> Bool
(FlowModel n e -> FlowModel n e -> Bool)
-> (FlowModel n e -> FlowModel n e -> Bool) -> Eq (FlowModel n e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall n e. (Eq n, Eq e) => FlowModel n e -> FlowModel n e -> Bool
$c== :: forall n e. (Eq n, Eq e) => FlowModel n e -> FlowModel n e -> Bool
== :: FlowModel n e -> FlowModel n e -> Bool
$c/= :: forall n e. (Eq n, Eq e) => FlowModel n e -> FlowModel n e -> Bool
/= :: FlowModel n e -> FlowModel n e -> Bool
Eq
-----------------------------------------------------------------------------
flowNodes :: FlowModel n e -> [Node n]
flowNodes :: forall n e. FlowModel n e -> [Node n]
flowNodes = FlowModel n e -> [Node n]
forall n e. FlowModel n e -> [Node n]
fmNodes
-----------------------------------------------------------------------------
flowEdges :: FlowModel n e -> [Edge e]
flowEdges :: forall n e. FlowModel n e -> [Edge e]
flowEdges = FlowModel n e -> [Edge e]
forall n e. FlowModel n e -> [Edge e]
fmEdges
-----------------------------------------------------------------------------
flowViewport :: FlowModel n e -> Viewport
flowViewport :: forall n e. FlowModel n e -> Viewport
flowViewport = FlowModel n e -> Viewport
forall n e. FlowModel n e -> Viewport
fmViewport
-----------------------------------------------------------------------------
flowConnection :: FlowModel n e -> ConnectionState n
flowConnection :: forall n e. FlowModel n e -> ConnectionState n
flowConnection = FlowModel n e -> ConnectionState n
forall n e. FlowModel n e -> ConnectionState n
fmConnection
-----------------------------------------------------------------------------
flowOptions :: FlowModel n e -> StoreOptions
flowOptions :: forall n e. FlowModel n e -> StoreOptions
flowOptions = FlowModel n e -> StoreOptions
forall n e. FlowModel n e -> StoreOptions
fmOptions
-----------------------------------------------------------------------------
-- | Initial model from user nodes and edges.
flowModel :: Eq n => StoreOptions -> [Node n] -> [Edge e] -> FlowModel n e
flowModel :: forall n e.
Eq n =>
StoreOptions -> [Node n] -> [Edge e] -> FlowModel n e
flowModel StoreOptions
options [Node n]
nodes [Edge e]
edges = FlowModel n e -> FlowModel n e
forall n e. Eq n => FlowModel n e -> FlowModel n e
resync FlowModel
  { fmNodes :: [Node n]
fmNodes = [Node n]
nodes
  , fmEdges :: [Edge e]
fmEdges = [Edge e]
edges
  , fmNodeLookup :: NodeLookup n
fmNodeLookup = NodeLookup n
forall k a. Map k a
M.empty
  , fmParentLookup :: ParentLookup n
fmParentLookup = ParentLookup n
forall k a. Map k a
M.empty
  , fmViewport :: Viewport
fmViewport = StoreOptions -> Viewport
soDefaultViewport StoreOptions
options
  , fmConnection :: ConnectionState n
fmConnection = ConnectionState n
forall n. ConnectionState n
NoConnection
  , fmStore :: Maybe FlowStore
fmStore = Maybe FlowStore
forall a. Maybe a
Nothing
  , fmPending :: PendingAttach
fmPending = PendingAttach
noPending
  , fmOptions :: StoreOptions
fmOptions = StoreOptions
options
  , fmDimensions :: Dimensions
fmDimensions = Dimensions
zeroDimensions
  , fmMinimap :: Maybe MinimapConfig
fmMinimap = Maybe MinimapConfig
forall a. Maybe a
Nothing
  , fmSelectionRect :: Maybe Rect
fmSelectionRect = Maybe Rect
forall a. Maybe a
Nothing
  }
-----------------------------------------------------------------------------
-- | Recompute the internal lookups from the user nodes.
resync :: Eq n => FlowModel n e -> FlowModel n e
resync :: forall n e. Eq n => FlowModel n e -> FlowModel n e
resync m :: FlowModel n e
m@FlowModel {[Edge e]
[Node n]
Maybe Rect
Maybe FlowStore
Maybe MinimapConfig
ParentLookup n
NodeLookup n
ConnectionState n
Dimensions
Viewport
StoreOptions
PendingAttach
fmNodes :: forall n e. FlowModel n e -> [Node n]
fmEdges :: forall n e. FlowModel n e -> [Edge e]
fmNodeLookup :: forall n e. FlowModel n e -> NodeLookup n
fmParentLookup :: forall n e. FlowModel n e -> ParentLookup n
fmViewport :: forall n e. FlowModel n e -> Viewport
fmConnection :: forall n e. FlowModel n e -> ConnectionState n
fmStore :: forall n e. FlowModel n e -> Maybe FlowStore
fmPending :: forall n e. FlowModel n e -> PendingAttach
fmOptions :: forall n e. FlowModel n e -> StoreOptions
fmDimensions :: forall n e. FlowModel n e -> Dimensions
fmMinimap :: forall n e. FlowModel n e -> Maybe MinimapConfig
fmSelectionRect :: forall n e. FlowModel n e -> Maybe Rect
fmNodes :: [Node n]
fmEdges :: [Edge e]
fmNodeLookup :: NodeLookup n
fmParentLookup :: ParentLookup n
fmViewport :: Viewport
fmConnection :: ConnectionState n
fmStore :: Maybe FlowStore
fmPending :: PendingAttach
fmOptions :: StoreOptions
fmDimensions :: Dimensions
fmMinimap :: Maybe MinimapConfig
fmSelectionRect :: Maybe Rect
..} =
  FlowModel n e
m { fmNodeLookup = nodeLookup, fmParentLookup = parentLookup }
  where
    (NodeLookup n
nodeLookup, ParentLookup n
parentLookup, AdoptUserNodesReturn
_) =
      [Node n]
-> NodeLookup n
-> UpdateNodesOptions n
-> (NodeLookup n, ParentLookup n, AdoptUserNodesReturn)
forall n.
Eq n =>
[Node n]
-> NodeLookup n
-> UpdateNodesOptions n
-> (NodeLookup n, ParentLookup n, AdoptUserNodesReturn)
adoptUserNodes [Node n]
fmNodes NodeLookup n
fmNodeLookup UpdateNodesOptions n
forall n. UpdateNodesOptions n
defaultUpdateNodesOptions
        { unoNodeOrigin = soNodeOrigin fmOptions
        , unoNodeExtent = fromMaybe infiniteExtent (soNodeExtent fmOptions)
        , unoElevateNodesOnSelect = soElevateNodesOnSelect fmOptions
        , unoZIndexMode = soZIndexMode fmOptions
        }
-----------------------------------------------------------------------------
data FlowAction n e
  = FlowCreated DOMRef
    -- ^ container mounted: create the JavaScript store
  | FlowStoreCreated FlowStore
  | FlowBeforeDestroyed
  | FlowNodeCreated NodeId DOMRef
  | FlowNodeBeforeDestroyed NodeId DOMRef
  | FlowHandleCreated DOMRef
  | FlowViewportChanged Viewport
  | FlowNodeChangesReceived [WireNodeChange]
  | FlowConnectionChanged ConnectionStateWire
  | FlowConnected Connection
  | FlowNodeMouseDown NodeId Bool
    -- ^ id and whether a multi-selection modifier was held
  | FlowEdgeClicked EdgeId
  | FlowUnselected
  | FlowSelectionChanged Rect
  | FlowSelectionFinished
  | FlowRemoveNode NodeId
  | FlowReconnected EdgeId Connection
    -- ^ an edge anchor was dropped on a new valid handle
  | FlowResizeStarted NodeId
    -- ^ extension point: no-op in 'updateFlow'
  | FlowResizeFinished NodeId
    -- ^ extension point: no-op in 'updateFlow'
  | FlowMinimapClicked XYPosition
    -- ^ centers the viewport on the clicked flow position
  | FlowDeletePressed
    -- ^ Delete\/Backspace: remove the current selection
  | FlowDimensionsChanged Dimensions
  | FlowResizerCreated NodeId Value DOMRef
  | FlowResizerBeforeDestroyed NodeId DOMRef
  | FlowMinimapCreated MinimapConfig DOMRef
  | FlowEdgeAnchorCreated DOMRef
  | FlowSetNodes [Node n]
  | FlowSetEdges [Edge e]
  | FlowOptionsChanged StoreOptions
    -- ^ change store options at runtime (zoom limits, snapping, …)
  | FlowZoomIn
  | FlowZoomOut
  | FlowZoomTo Double
  | FlowSetCenterOn XYPosition
    -- ^ center the viewport on a flow position
  | FlowFitBounds Rect
    -- ^ fit the viewport to a flow-coordinate rectangle
  | FlowFitView
  | FlowErrorRaised MisoString MisoString
-----------------------------------------------------------------------------
-- | The standard wiring of VDOM lifecycle events into 'FlowAction's.
flowHooks :: FlowHooks (FlowAction n e)
flowHooks :: forall n e. FlowHooks (FlowAction n e)
flowHooks = FlowHooks
  { hookFlowCreated :: DOMRef -> FlowAction n e
hookFlowCreated = DOMRef -> FlowAction n e
forall n e. DOMRef -> FlowAction n e
FlowCreated
  , hookFlowBeforeDestroyed :: FlowAction n e
hookFlowBeforeDestroyed = FlowAction n e
forall n e. FlowAction n e
FlowBeforeDestroyed
  , hookNodeCreated :: MisoString -> DOMRef -> FlowAction n e
hookNodeCreated = MisoString -> DOMRef -> FlowAction n e
forall n e. MisoString -> DOMRef -> FlowAction n e
FlowNodeCreated
  , hookNodeBeforeDestroyed :: MisoString -> DOMRef -> FlowAction n e
hookNodeBeforeDestroyed = MisoString -> DOMRef -> FlowAction n e
forall n e. MisoString -> DOMRef -> FlowAction n e
FlowNodeBeforeDestroyed
  , hookHandleCreated :: DOMRef -> FlowAction n e
hookHandleCreated = DOMRef -> FlowAction n e
forall n e. DOMRef -> FlowAction n e
FlowHandleCreated
  , hookEdgeClick :: Maybe (MisoString -> FlowAction n e)
hookEdgeClick = (MisoString -> FlowAction n e)
-> Maybe (MisoString -> FlowAction n e)
forall a. a -> Maybe a
Just MisoString -> FlowAction n e
forall n e. MisoString -> FlowAction n e
FlowEdgeClicked
  , hookNodeClick :: Maybe (MisoString -> Bool -> FlowAction n e)
hookNodeClick = (MisoString -> Bool -> FlowAction n e)
-> Maybe (MisoString -> Bool -> FlowAction n e)
forall a. a -> Maybe a
Just MisoString -> Bool -> FlowAction n e
forall n e. MisoString -> Bool -> FlowAction n e
FlowNodeMouseDown
  , hookResizerCreated :: MisoString -> Value -> DOMRef -> FlowAction n e
hookResizerCreated = MisoString -> Value -> DOMRef -> FlowAction n e
forall n e. MisoString -> Value -> DOMRef -> FlowAction n e
FlowResizerCreated
  , hookResizerBeforeDestroyed :: MisoString -> DOMRef -> FlowAction n e
hookResizerBeforeDestroyed = MisoString -> DOMRef -> FlowAction n e
forall n e. MisoString -> DOMRef -> FlowAction n e
FlowResizerBeforeDestroyed
  , hookMinimapCreated :: MinimapConfig -> DOMRef -> FlowAction n e
hookMinimapCreated = MinimapConfig -> DOMRef -> FlowAction n e
forall n e. MinimapConfig -> DOMRef -> FlowAction n e
FlowMinimapCreated
  , hookEdgeAnchorCreated :: DOMRef -> FlowAction n e
hookEdgeAnchorCreated = DOMRef -> FlowAction n e
forall n e. DOMRef -> FlowAction n e
FlowEdgeAnchorCreated
  }
-----------------------------------------------------------------------------
-- | Bridge callbacks dispatching into the update loop.
flowCallbacks :: (FlowAction n e -> IO ()) -> BridgeCallbacks
flowCallbacks :: forall n e. (FlowAction n e -> IO ()) -> BridgeCallbacks
flowCallbacks FlowAction n e -> IO ()
sink = BridgeCallbacks
emptyBridgeCallbacks
  { bcViewport = sink . FlowViewportChanged
  , bcNodeChanges = sink . FlowNodeChangesReceived
  , bcResizeChanges = sink . FlowNodeChangesReceived
  , bcConnectionUpdate = sink . FlowConnectionChanged
  , bcConnect = sink . FlowConnected
  , bcNodeMouseDown = \MisoString
nid Bool
multi -> FlowAction n e -> IO ()
sink (MisoString -> Bool -> FlowAction n e
forall n e. MisoString -> Bool -> FlowAction n e
FlowNodeMouseDown MisoString
nid Bool
multi)
  , bcSelectionRect = sink . FlowSelectionChanged
  , bcSelectionEnd = \Rect
_ -> FlowAction n e -> IO ()
sink FlowAction n e
forall n e. FlowAction n e
FlowSelectionFinished
  , bcReconnect = \MisoString
eid Connection
c -> FlowAction n e -> IO ()
sink (MisoString -> Connection -> FlowAction n e
forall n e. MisoString -> Connection -> FlowAction n e
FlowReconnected MisoString
eid Connection
c)
  , bcResizeStart = sink . FlowResizeStarted
  , bcResizeEnd = sink . FlowResizeFinished
  , bcMinimapClick = sink . FlowMinimapClicked
  , bcDeleteKey = sink FlowDeletePressed
  , bcUnselectAll = sink FlowUnselected
  , bcPaneClick = sink FlowUnselected
  , bcDimensions = sink . FlowDimensionsChanged
  , bcError = \MisoString
code MisoString
msg -> FlowAction n e -> IO ()
sink (MisoString -> MisoString -> FlowAction n e
forall n e. MisoString -> MisoString -> FlowAction n e
FlowErrorRaised MisoString
code MisoString
msg)
  }
-----------------------------------------------------------------------------
-- | 'updateFlowWith' with default settings.
updateFlow
  :: Eq n
  => FlowAction n e
  -> Effect ctx props (FlowModel n e) (FlowAction n e)
updateFlow :: forall n e ctx props.
Eq n =>
FlowAction n e -> Effect ctx props (FlowModel n e) (FlowAction n e)
updateFlow = FlowSettings
-> FlowAction n e
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall n e ctx props.
Eq n =>
FlowSettings
-> FlowAction n e
-> Effect ctx props (FlowModel n e) (FlowAction n e)
updateFlowWith FlowSettings
defaultFlowSettings
-----------------------------------------------------------------------------
-- | Transition function; embed it directly if you are not using
-- 'flowComponent'.
updateFlowWith
  :: Eq n
  => FlowSettings
  -> FlowAction n e
  -> Effect ctx props (FlowModel n e) (FlowAction n e)
updateFlowWith :: forall n e ctx props.
Eq n =>
FlowSettings
-> FlowAction n e
-> Effect ctx props (FlowModel n e) (FlowAction n e)
updateFlowWith FlowSettings
settings = \case

  FlowCreated DOMRef
domRef -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    withSink $ \Sink (FlowAction n e)
sink -> do
      store <- DOMRef
-> StoreOptions
-> Maybe (Connection -> Bool)
-> BridgeCallbacks
-> IO FlowStore
createFlowStore DOMRef
domRef (FlowModel n e -> StoreOptions
forall n e. FlowModel n e -> StoreOptions
fmOptions FlowModel n e
m)
        (FlowSettings -> Maybe (Connection -> Bool)
fsValidateConnection FlowSettings
settings) (Sink (FlowAction n e) -> BridgeCallbacks
forall n e. (FlowAction n e -> IO ()) -> BridgeCallbacks
flowCallbacks Sink (FlowAction n e)
sink)
      sink (FlowStoreCreated store)

  FlowStoreCreated FlowStore
store -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    let PendingAttach ns hs rs mms = fmPending m
    put m
      { fmStore = Just store
      , fmPending = noPending
      , fmMinimap = case mms of
          (MinimapConfig
c, DOMRef
_) : [(MinimapConfig, DOMRef)]
_ -> MinimapConfig -> Maybe MinimapConfig
forall a. a -> Maybe a
Just MinimapConfig
c
          [] -> FlowModel n e -> Maybe MinimapConfig
forall n e. FlowModel n e -> Maybe MinimapConfig
fmMinimap FlowModel n e
m
      }
    io_ $ do
      storeSetNodes store (fmNodes m)
      storeSetEdges store (fmEdges m)
      mapM_ (attachNode store) (reverse ns)
      mapM_ (storeAttachHandle store) (reverse hs)
      mapM_ (\(MisoString
nid, Value
params, DOMRef
ref) -> FlowStore -> DOMRef -> MisoString -> Value -> IO ()
storeAttachResizer FlowStore
store DOMRef
ref MisoString
nid Value
params) (reverse rs)
      mapM_ (\(MinimapConfig
c, DOMRef
ref) -> FlowStore -> DOMRef -> Value -> IO ()
storeAttachMinimap FlowStore
store DOMRef
ref (MinimapConfig -> Double -> Value
minimapParams MinimapConfig
c Double
1)) (reverse mms)
    syncMinimap

  FlowAction n e
FlowBeforeDestroyed -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    put m { fmStore = Nothing, fmPending = noPending }
    mapM_ (io_ . storeDestroy) (fmStore m)

  FlowNodeCreated MisoString
nid DOMRef
domRef -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    case fmStore m of
      Just FlowStore
store -> IO () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall context props model action.
IO () -> Effect context props model action
io_ (FlowStore -> (MisoString, DOMRef) -> IO ()
attachNode FlowStore
store (MisoString
nid, DOMRef
domRef))
      Maybe FlowStore
Nothing -> FlowModel n e -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => s -> m ()
put FlowModel n e
m
        { fmPending = (fmPending m)
            { pendingNodes = (nid, domRef) : pendingNodes (fmPending m) }
        }

  FlowNodeBeforeDestroyed MisoString
nid DOMRef
domRef -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    mapM_
      (\FlowStore
store -> IO () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall context props model action.
IO () -> Effect context props model action
io_ (IO () -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> IO () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ do
          FlowStore -> DOMRef -> IO ()
storeUnobserveNode FlowStore
store DOMRef
domRef
          FlowStore -> MisoString -> IO ()
storeDetachNodeDrag FlowStore
store MisoString
nid)
      (fmStore m)

  FlowHandleCreated DOMRef
domRef -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    case fmStore m of
      Just FlowStore
store -> IO () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall context props model action.
IO () -> Effect context props model action
io_ (FlowStore -> DOMRef -> IO ()
storeAttachHandle FlowStore
store DOMRef
domRef)
      Maybe FlowStore
Nothing -> FlowModel n e -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => s -> m ()
put FlowModel n e
m
        { fmPending = (fmPending m)
            { pendingHandles = domRef : pendingHandles (fmPending m) }
        }

  FlowViewportChanged Viewport
viewport -> do
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m -> FlowModel n e
m { fmViewport = viewport }
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
syncMinimap

  FlowNodeChangesReceived [WireNodeChange]
changes -> do
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m -> FlowModel n e -> FlowModel n e
forall n e. Eq n => FlowModel n e -> FlowModel n e
resync ((FlowModel n e -> WireNodeChange -> FlowModel n e)
-> FlowModel n e -> [WireNodeChange] -> FlowModel n e
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((WireNodeChange -> FlowModel n e -> FlowModel n e)
-> FlowModel n e -> WireNodeChange -> FlowModel n e
forall a b c. (a -> b -> c) -> b -> a -> c
flip WireNodeChange -> FlowModel n e -> FlowModel n e
forall n e. WireNodeChange -> FlowModel n e -> FlowModel n e
applyWireChange) FlowModel n e
m [WireNodeChange]
changes)
    -- keep the JavaScript lookup in step (resize changes and removals
    -- are not applied on the JS side by the bridge itself)
    Bool
-> Effect ctx props (FlowModel n e) (FlowAction n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((WireNodeChange -> Bool) -> [WireNodeChange] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any WireNodeChange -> Bool
needsJsSync [WireNodeChange]
changes) Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
pushGraph
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
syncMinimap

  FlowConnectionChanged ConnectionStateWire
wire ->
    -- the gesture system reports @to@ / @pointer@ in pane (screen)
    -- coordinates while @from@ is already in flow coordinates; convert
    -- before rendering, as the framework packages do in useConnection
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m ->
      let toFlow :: XYPosition -> XYPosition
toFlow XYPosition
p = XYPosition -> Viewport -> Bool -> SnapGrid -> XYPosition
pointToRendererPoint XYPosition
p (FlowModel n e -> Viewport
forall n e. FlowModel n e -> Viewport
fmViewport FlowModel n e
m) Bool
False (Double -> Double -> SnapGrid
SnapGrid Double
1 Double
1)
          wire' :: ConnectionStateWire
wire' = ConnectionStateWire
wire
            { cwTo = toFlow <$> cwTo wire
            , cwPointer = toFlow <$> cwPointer wire
            }
      in FlowModel n e
m { fmConnection =
               wireConnectionState (`M.lookup` fmNodeLookup m) wire'
           }

  FlowConnected Connection
c -> do
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m -> FlowModel n e
m { fmEdges = addEdge c (fmEdges m) }
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
pushEdges

  FlowNodeMouseDown MisoString
nid Bool
multi
    -- multi-modifier: toggle this node, keep the rest
    | Bool
multi -> do
        (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m -> FlowModel n e -> FlowModel n e
forall n e. Eq n => FlowModel n e -> FlowModel n e
resync FlowModel n e
m
          { fmNodes =
              [ if nodeId n == nid
                  then n { nodeSelected = not (nodeSelected n) }
                  else n
              | n <- fmNodes m
              ]
          }
        Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
pushGraph
    | Bool
otherwise -> do
        m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
        -- mousedown on an already-selected node keeps the selection
        -- (that is how a multi-selection gets dragged as a group)
        let alreadySelected =
              (Node n -> Bool) -> [Node n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Node n
n -> Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n MisoString -> MisoString -> Bool
forall a. Eq a => a -> a -> Bool
== MisoString
nid Bool -> Bool -> Bool
&& Node n -> Bool
forall n. Node n -> Bool
nodeSelected Node n
n) (FlowModel n e -> [Node n]
forall n e. FlowModel n e -> [Node n]
fmNodes FlowModel n e
m)
        unless alreadySelected $ do
          put $ resync m
            { fmNodes =
                [ n { nodeSelected = nodeId n == nid } | n <- fmNodes m ]
            , fmEdges = [ e { edgeSelected = False } | e <- fmEdges m ]
            }
          pushGraph

  FlowEdgeClicked MisoString
eid -> do
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m -> FlowModel n e -> FlowModel n e
forall n e. Eq n => FlowModel n e -> FlowModel n e
resync FlowModel n e
m
      { fmNodes = [ n { nodeSelected = False } | n <- fmNodes m ]
      , fmEdges = [ e { edgeSelected = edgeId e == eid } | e <- fmEdges m ]
      }
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
pushGraph

  FlowAction n e
FlowUnselected -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    let selected =
          (Node n -> Bool) -> [Node n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node n -> Bool
forall n. Node n -> Bool
nodeSelected (FlowModel n e -> [Node n]
forall n e. FlowModel n e -> [Node n]
fmNodes FlowModel n e
m) Bool -> Bool -> Bool
|| (Edge e -> Bool) -> [Edge e] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Edge e -> Bool
forall e. Edge e -> Bool
edgeSelected (FlowModel n e -> [Edge e]
forall n e. FlowModel n e -> [Edge e]
fmEdges FlowModel n e
m)
    when selected $ do
      put $ resync m
        { fmNodes = [ n { nodeSelected = False } | n <- fmNodes m ]
        , fmEdges = [ e { edgeSelected = False } | e <- fmEdges m ]
        }
      pushGraph

  FlowSelectionChanged Rect
rect -> do
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m ->
      let inside :: Set MisoString
inside =
            [MisoString] -> Set MisoString
forall a. Ord a => [a] -> Set a
S.fromList
              [ Node n -> MisoString
forall n. Node n -> MisoString
nodeId (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUserNode InternalNode n
n)
              | InternalNode n
n <- Map MisoString (InternalNode n)
-> Rect -> Viewport -> Bool -> Bool -> [InternalNode n]
forall n.
NodeLookup n
-> Rect -> Viewport -> Bool -> Bool -> [InternalNode n]
getNodesInside (FlowModel n e -> Map MisoString (InternalNode n)
forall n e. FlowModel n e -> NodeLookup n
fmNodeLookup FlowModel n e
m) Rect
rect (FlowModel n e -> Viewport
forall n e. FlowModel n e -> Viewport
fmViewport FlowModel n e
m) Bool
False Bool
False
              ]
          nodes :: [Node n]
nodes = [ Node n
n { nodeSelected = nodeId n `S.member` inside } | Node n
n <- FlowModel n e -> [Node n]
forall n e. FlowModel n e -> [Node n]
fmNodes FlowModel n e
m ]
      in FlowModel n e -> FlowModel n e
forall n e. Eq n => FlowModel n e -> FlowModel n e
resync FlowModel n e
m
           { fmSelectionRect = Just rect
           , fmNodes = nodes
           , fmEdges =
               [ e { edgeSelected =
                       edgeSource e `S.member` inside
                         && edgeTarget e `S.member` inside }
               | e <- fmEdges m
               ]
           }
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
pushGraph

  FlowAction n e
FlowSelectionFinished ->
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m -> FlowModel n e
m { fmSelectionRect = Nothing }

  FlowRemoveNode MisoString
nid -> do
    -- cascade through children (and their edges) like the delete key
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m ->
      let ([Node n]
goneNodes, [Edge e]
goneEdges) =
            [MisoString]
-> [MisoString] -> [Node n] -> [Edge e] -> ([Node n], [Edge e])
forall n e.
[MisoString]
-> [MisoString] -> [Node n] -> [Edge e] -> ([Node n], [Edge e])
getElementsToRemove [ MisoString
nid ] [] (FlowModel n e -> [Node n]
forall n e. FlowModel n e -> [Node n]
fmNodes FlowModel n e
m) (FlowModel n e -> [Edge e]
forall n e. FlowModel n e -> [Edge e]
fmEdges FlowModel n e
m)
          goneNodeIds :: Set MisoString
goneNodeIds = [MisoString] -> Set MisoString
forall a. Ord a => [a] -> Set a
S.fromList ((Node n -> MisoString) -> [Node n] -> [MisoString]
forall a b. (a -> b) -> [a] -> [b]
map Node n -> MisoString
forall n. Node n -> MisoString
nodeId [Node n]
goneNodes)
          goneEdgeIds :: Set MisoString
goneEdgeIds = [MisoString] -> Set MisoString
forall a. Ord a => [a] -> Set a
S.fromList ((Edge e -> MisoString) -> [Edge e] -> [MisoString]
forall a b. (a -> b) -> [a] -> [b]
map Edge e -> MisoString
forall e. Edge e -> MisoString
edgeId [Edge e]
goneEdges)
      in FlowModel n e -> FlowModel n e
forall n e. Eq n => FlowModel n e -> FlowModel n e
resync FlowModel n e
m
           { fmNodes =
               [ n | n <- fmNodes m, nodeId n `S.notMember` goneNodeIds ]
           , fmEdges =
               [ e
               | e <- fmEdges m
               , edgeId e `S.notMember` goneEdgeIds
               , edgeSource e `S.notMember` goneNodeIds
               , edgeTarget e `S.notMember` goneNodeIds
               ]
           }
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
pushGraph
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
syncMinimap

  FlowReconnected MisoString
eid Connection
c -> do
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m ->
      case [ Edge e
e | Edge e
e <- FlowModel n e -> [Edge e]
forall n e. FlowModel n e -> [Edge e]
fmEdges FlowModel n e
m, Edge e -> MisoString
forall e. Edge e -> MisoString
edgeId Edge e
e MisoString -> MisoString -> Bool
forall a. Eq a => a -> a -> Bool
== MisoString
eid ] of
        (Edge e
old : [Edge e]
_) -> FlowModel n e
m { fmEdges = reconnectEdge old c (fmEdges m) }
        [] -> FlowModel n e
m
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
pushEdges

  FlowResizeStarted MisoString
_ -> () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a.
a
-> RWST
     (ComponentInfo ctx props)
     [Schedule ctx (FlowAction n e)]
     (FlowModel n e)
     Identity
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  FlowResizeFinished MisoString
_ -> () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a.
a
-> RWST
     (ComponentInfo ctx props)
     [Schedule ctx (FlowAction n e)]
     (FlowModel n e)
     Identity
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  FlowMinimapClicked (XYPosition Double
x Double
y) ->
    (FlowStore -> IO ())
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
(FlowStore -> IO ())
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
onStore (\FlowStore
s -> FlowStore -> Double -> Double -> SetCenterOptions -> IO ()
storeSetCenter FlowStore
s Double
x Double
y SetCenterOptions
defaultSetCenterOptions)
    -- (same as 'FlowSetCenterOn'; kept separate so embedders can treat
    -- minimap clicks differently)

  FlowAction n e
FlowDeletePressed -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    let selectedNodes = [ Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n | Node n
n <- FlowModel n e -> [Node n]
forall n e. FlowModel n e -> [Node n]
fmNodes FlowModel n e
m, Node n -> Bool
forall n. Node n -> Bool
nodeSelected Node n
n ]
        selectedEdges = [ Edge e -> MisoString
forall e. Edge e -> MisoString
edgeId Edge e
e | Edge e
e <- FlowModel n e -> [Edge e]
forall n e. FlowModel n e -> [Edge e]
fmEdges FlowModel n e
m, Edge e -> Bool
forall e. Edge e -> Bool
edgeSelected Edge e
e ]
        (goneNodes, goneEdges) =
          getElementsToRemove selectedNodes selectedEdges (fmNodes m) (fmEdges m)
        goneNodeIds = [MisoString] -> Set MisoString
forall a. Ord a => [a] -> Set a
S.fromList ((Node n -> MisoString) -> [Node n] -> [MisoString]
forall a b. (a -> b) -> [a] -> [b]
map Node n -> MisoString
forall n. Node n -> MisoString
nodeId [Node n]
goneNodes)
        goneEdgeIds = [MisoString] -> Set MisoString
forall a. Ord a => [a] -> Set a
S.fromList ((Edge e -> MisoString) -> [Edge e] -> [MisoString]
forall a b. (a -> b) -> [a] -> [b]
map Edge e -> MisoString
forall e. Edge e -> MisoString
edgeId [Edge e]
goneEdges)
    when (not (null goneNodes) || not (null goneEdges)) $ do
      put $ resync m
        { fmNodes = [ n | n <- fmNodes m, nodeId n `S.notMember` goneNodeIds ]
        , fmEdges =
            [ e
            | e <- fmEdges m
            , edgeId e `S.notMember` goneEdgeIds
            , edgeSource e `S.notMember` goneNodeIds
            , edgeTarget e `S.notMember` goneNodeIds
            ]
        }
      pushGraph
      syncMinimap

  FlowEdgeAnchorCreated DOMRef
domRef -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    -- anchors only render on selected edges, which implies the store
    -- already exists; if it somehow doesn't, the anchor is inert
    mapM_ (\FlowStore
store -> IO () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall context props model action.
IO () -> Effect context props model action
io_ (FlowStore -> DOMRef -> IO ()
storeAttachReconnectAnchor FlowStore
store DOMRef
domRef)) (fmStore m)

  FlowDimensionsChanged Dimensions
dims -> do
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m -> FlowModel n e
m { fmDimensions = dims }
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
syncMinimap

  FlowResizerCreated MisoString
nid Value
params DOMRef
domRef -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    case fmStore m of
      Just FlowStore
store -> IO () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall context props model action.
IO () -> Effect context props model action
io_ (FlowStore -> DOMRef -> MisoString -> Value -> IO ()
storeAttachResizer FlowStore
store DOMRef
domRef MisoString
nid Value
params)
      Maybe FlowStore
Nothing -> FlowModel n e -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => s -> m ()
put FlowModel n e
m
        { fmPending = (fmPending m)
            { pendingResizers = (nid, params, domRef) : pendingResizers (fmPending m) }
        }

  FlowResizerBeforeDestroyed MisoString
nid DOMRef
domRef -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    mapM_ (\FlowStore
store -> IO () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall context props model action.
IO () -> Effect context props model action
io_ (FlowStore -> MisoString -> DOMRef -> IO ()
storeDetachResizer FlowStore
store MisoString
nid DOMRef
domRef)) (fmStore m)

  FlowMinimapCreated MinimapConfig
cfg DOMRef
domRef -> do
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    case fmStore m of
      Just FlowStore
store -> do
        FlowModel n e -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => s -> m ()
put FlowModel n e
m { fmMinimap = Just cfg }
        IO () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall context props model action.
IO () -> Effect context props model action
io_ (FlowStore -> DOMRef -> Value -> IO ()
storeAttachMinimap FlowStore
store DOMRef
domRef (MinimapConfig -> Double -> Value
minimapParams MinimapConfig
cfg Double
1))
        Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
syncMinimap
      Maybe FlowStore
Nothing -> FlowModel n e -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => s -> m ()
put FlowModel n e
m
        { fmMinimap = Just cfg
        , fmPending = (fmPending m)
            { pendingMinimaps = (cfg, domRef) : pendingMinimaps (fmPending m) }
        }

  FlowSetNodes [Node n]
nodes -> do
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m -> FlowModel n e -> FlowModel n e
forall n e. Eq n => FlowModel n e -> FlowModel n e
resync FlowModel n e
m { fmNodes = nodes }
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
pushGraph
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
syncMinimap

  FlowSetEdges [Edge e]
edges -> do
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m -> FlowModel n e
m { fmEdges = edges }
    Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
pushEdges

  FlowOptionsChanged StoreOptions
options -> do
    (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FlowModel n e -> FlowModel n e)
 -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowModel n e)
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a b. (a -> b) -> a -> b
$ \FlowModel n e
m -> FlowModel n e -> FlowModel n e
forall n e. Eq n => FlowModel n e -> FlowModel n e
resync FlowModel n e
m { fmOptions = options }
    m <- RWST
  (ComponentInfo ctx props)
  [Schedule ctx (FlowAction n e)]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
    mapM_ (\FlowStore
store -> IO () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall context props model action.
IO () -> Effect context props model action
io_ (FlowStore -> StoreOptions -> IO ()
storeUpdateOptions FlowStore
store StoreOptions
options)) (fmStore m)

  FlowAction n e
FlowZoomIn -> (FlowStore -> IO ())
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
(FlowStore -> IO ())
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
onStore (FlowStore -> ViewportHelperOptions -> IO ()
`storeZoomIn` ViewportHelperOptions
defaultViewportHelperOptions)

  FlowAction n e
FlowZoomOut -> (FlowStore -> IO ())
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
(FlowStore -> IO ())
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
onStore (FlowStore -> ViewportHelperOptions -> IO ()
`storeZoomOut` ViewportHelperOptions
defaultViewportHelperOptions)

  FlowZoomTo Double
zoom ->
    (FlowStore -> IO ())
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
(FlowStore -> IO ())
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
onStore (\FlowStore
s -> FlowStore -> Double -> ViewportHelperOptions -> IO ()
storeZoomTo FlowStore
s Double
zoom ViewportHelperOptions
defaultViewportHelperOptions)

  FlowSetCenterOn (XYPosition Double
x Double
y) ->
    (FlowStore -> IO ())
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
(FlowStore -> IO ())
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
onStore (\FlowStore
s -> FlowStore -> Double -> Double -> SetCenterOptions -> IO ()
storeSetCenter FlowStore
s Double
x Double
y SetCenterOptions
defaultSetCenterOptions)

  FlowFitBounds Rect
bounds ->
    (FlowStore -> IO ())
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
(FlowStore -> IO ())
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
onStore (\FlowStore
s -> FlowStore -> Rect -> FitBoundsOptions -> IO ()
storeFitBounds FlowStore
s Rect
bounds
      (Double -> ViewportHelperOptions -> FitBoundsOptions
FitBoundsOptions Double
0.1 ViewportHelperOptions
defaultViewportHelperOptions))

  FlowAction n e
FlowFitView -> (FlowStore -> IO ())
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall {context} {props} {action} {n} {e}.
(FlowStore -> IO ())
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
onStore (FlowStore -> FitViewOptions -> IO ()
`storeFitView` FitViewOptions
defaultFitViewOptions)

  FlowErrorRaised MisoString
_ MisoString
_ -> () -> Effect ctx props (FlowModel n e) (FlowAction n e)
forall a.
a
-> RWST
     (ComponentInfo ctx props)
     [Schedule ctx (FlowAction n e)]
     (FlowModel n e)
     Identity
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  where
    onStore :: (FlowStore -> IO ())
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
onStore FlowStore -> IO ()
f = RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  (FlowModel n e)
-> (FlowModel n e
    -> RWST
         (ComponentInfo context props)
         [Schedule context action]
         (FlowModel n e)
         Identity
         ())
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
forall a b.
RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  a
-> (a
    -> RWST
         (ComponentInfo context props)
         [Schedule context action]
         (FlowModel n e)
         Identity
         b)
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FlowStore
 -> RWST
      (ComponentInfo context props)
      [Schedule context action]
      (FlowModel n e)
      Identity
      ())
-> Maybe FlowStore
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO ()
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
forall context props model action.
IO () -> Effect context props model action
io_ (IO ()
 -> RWST
      (ComponentInfo context props)
      [Schedule context action]
      (FlowModel n e)
      Identity
      ())
-> (FlowStore -> IO ())
-> FlowStore
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlowStore -> IO ()
f) (Maybe FlowStore
 -> RWST
      (ComponentInfo context props)
      [Schedule context action]
      (FlowModel n e)
      Identity
      ())
-> (FlowModel n e -> Maybe FlowStore)
-> FlowModel n e
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlowModel n e -> Maybe FlowStore
forall n e. FlowModel n e -> Maybe FlowStore
fmStore
    pushGraph :: RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
pushGraph = do
      m <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
      mapM_ (\FlowStore
s -> IO ()
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
forall context props model action.
IO () -> Effect context props model action
io_ (FlowStore -> [Node n] -> IO ()
forall n. FlowStore -> [Node n] -> IO ()
storeSetNodes FlowStore
s (FlowModel n e -> [Node n]
forall n e. FlowModel n e -> [Node n]
fmNodes FlowModel n e
m) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FlowStore -> [Edge e] -> IO ()
forall e. FlowStore -> [Edge e] -> IO ()
storeSetEdges FlowStore
s (FlowModel n e -> [Edge e]
forall n e. FlowModel n e -> [Edge e]
fmEdges FlowModel n e
m))) (fmStore m)
    pushEdges :: RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
pushEdges = do
      m <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
      mapM_ (\FlowStore
s -> IO ()
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
forall context props model action.
IO () -> Effect context props model action
io_ (FlowStore -> [Edge e] -> IO ()
forall e. FlowStore -> [Edge e] -> IO ()
storeSetEdges FlowStore
s (FlowModel n e -> [Edge e]
forall n e. FlowModel n e -> [Edge e]
fmEdges FlowModel n e
m))) (fmStore m)
    syncMinimap :: RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  ()
syncMinimap = do
      m <- RWST
  (ComponentInfo context props)
  [Schedule context action]
  (FlowModel n e)
  Identity
  (FlowModel n e)
forall s (m :: * -> *). MonadState s m => m s
get
      case (fmStore m, fmMinimap m) of
        (Just FlowStore
store, Just MinimapConfig
cfg) ->
          IO ()
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
forall context props model action.
IO () -> Effect context props model action
io_ (IO ()
 -> RWST
      (ComponentInfo context props)
      [Schedule context action]
      (FlowModel n e)
      Identity
      ())
-> IO ()
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
forall a b. (a -> b) -> a -> b
$ FlowStore -> Value -> IO ()
storeUpdateMinimap FlowStore
store (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ MinimapConfig -> Double -> Value
minimapParams MinimapConfig
cfg (Double -> Value) -> Double -> Value
forall a b. (a -> b) -> a -> b
$
            MinimapConfig -> Dimensions -> Viewport -> NodeLookup n -> Double
forall n.
MinimapConfig -> Dimensions -> Viewport -> NodeLookup n -> Double
minimapViewScaleFor MinimapConfig
cfg (FlowModel n e -> Dimensions
forall n e. FlowModel n e -> Dimensions
fmDimensions FlowModel n e
m) (FlowModel n e -> Viewport
forall n e. FlowModel n e -> Viewport
fmViewport FlowModel n e
m) (FlowModel n e -> NodeLookup n
forall n e. FlowModel n e -> NodeLookup n
fmNodeLookup FlowModel n e
m)
        (Maybe FlowStore, Maybe MinimapConfig)
_ -> ()
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     ()
forall a.
a
-> RWST
     (ComponentInfo context props)
     [Schedule context action]
     (FlowModel n e)
     Identity
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
-----------------------------------------------------------------------------
-- | XYMinimap update parameters for a config and view scale.
minimapParams :: MinimapConfig -> Double -> Value
minimapParams :: MinimapConfig -> Double -> Value
minimapParams MinimapConfig {Bool
Double
PanelPosition
mmWidth :: Double
mmHeight :: Double
mmPosition :: PanelPosition
mmPannable :: Bool
mmZoomable :: Bool
mmInversePan :: Bool
mmZoomStep :: Double
mmNodeBorderRadius :: Double
mmOffsetScale :: Double
mmHeight :: MinimapConfig -> Double
mmInversePan :: MinimapConfig -> Bool
mmNodeBorderRadius :: MinimapConfig -> Double
mmOffsetScale :: MinimapConfig -> Double
mmPannable :: MinimapConfig -> Bool
mmPosition :: MinimapConfig -> PanelPosition
mmWidth :: MinimapConfig -> Double
mmZoomStep :: MinimapConfig -> Double
mmZoomable :: MinimapConfig -> Bool
..} Double
viewScale = [(MisoString, Value)] -> Value
object
  [ MisoString
"viewScale" MisoString -> Double -> (MisoString, Value)
forall v. ToJSON v => MisoString -> v -> (MisoString, Value)
.= Double
viewScale
  , MisoString
"inversePan" MisoString -> Bool -> (MisoString, Value)
forall v. ToJSON v => MisoString -> v -> (MisoString, Value)
.= Bool
mmInversePan
  , MisoString
"zoomStep" MisoString -> Double -> (MisoString, Value)
forall v. ToJSON v => MisoString -> v -> (MisoString, Value)
.= Double
mmZoomStep
  , MisoString
"pannable" MisoString -> Bool -> (MisoString, Value)
forall v. ToJSON v => MisoString -> v -> (MisoString, Value)
.= Bool
mmPannable
  , MisoString
"zoomable" MisoString -> Bool -> (MisoString, Value)
forall v. ToJSON v => MisoString -> v -> (MisoString, Value)
.= Bool
mmZoomable
  ]
-----------------------------------------------------------------------------
attachNode :: FlowStore -> (NodeId, DOMRef) -> IO ()
attachNode :: FlowStore -> (MisoString, DOMRef) -> IO ()
attachNode FlowStore
store (MisoString
nid, DOMRef
domRef) = do
  FlowStore -> DOMRef -> IO ()
storeObserveNode FlowStore
store DOMRef
domRef
  FlowStore -> DOMRef -> MisoString -> IO ()
storeAttachNodeDrag FlowStore
store DOMRef
domRef MisoString
nid
-----------------------------------------------------------------------------
-- | Which wire changes leave the JavaScript store's own lookup stale.
needsJsSync :: WireNodeChange -> Bool
needsJsSync :: WireNodeChange -> Bool
needsJsSync = \case
  WirePositionChange {} -> Bool
False -- XYDrag updates the JS lookup itself
  WireDimensionChange MisoString
_ Maybe Dimensions
_ Maybe Bool
resizing SetAttributes
setAttrs Maybe NodeHandleBounds
_ Maybe XYPosition
_ ->
    Maybe Bool
resizing Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Bool -> Bool -> Bool
|| SetAttributes
setAttrs SetAttributes -> SetAttributes -> Bool
forall a. Eq a => a -> a -> Bool
/= SetAttributes
SetAttributesNone
  WireSelectionChange {} -> Bool
True
  WireRemoveChange {} -> Bool
True
-----------------------------------------------------------------------------
-- | Fold one JS-reported change into the model (the user nodes carry
-- @measured@, like in xyflow; 'resync' then rebuilds the lookup and
-- 'applyMeasurement' merges the DOM-measured handle bounds).
applyWireChange :: WireNodeChange -> FlowModel n e -> FlowModel n e
applyWireChange :: forall n e. WireNodeChange -> FlowModel n e -> FlowModel n e
applyWireChange WireNodeChange
change FlowModel n e
m = case WireNodeChange
change of
  WirePositionChange MisoString
nid Maybe XYPosition
mPosition Maybe XYPosition
_ Maybe Bool
mDragging ->
    MisoString -> (Node n -> Node n) -> FlowModel n e
onNode MisoString
nid ((Node n -> Node n) -> FlowModel n e)
-> (Node n -> Node n) -> FlowModel n e
forall a b. (a -> b) -> a -> b
$ \Node n
n -> Node n
n
      { nodePosition = fromMaybe (nodePosition n) mPosition
      , nodeDragging = fromMaybe (nodeDragging n) mDragging
      }
  WireDimensionChange MisoString
nid Maybe Dimensions
mDims Maybe Bool
mResizing SetAttributes
setAttrs Maybe NodeHandleBounds
mHandleBounds Maybe XYPosition
mPosAbs ->
    let withDims :: FlowModel n e
withDims = MisoString -> (Node n -> Node n) -> FlowModel n e
onNode MisoString
nid ((Node n -> Node n) -> FlowModel n e)
-> (Node n -> Node n) -> FlowModel n e
forall a b. (a -> b) -> a -> b
$ \Node n
n -> Node n
n
          { nodeMeasured =
              maybe (nodeMeasured n)
                (\(Dimensions Double
w Double
h) -> Measured -> Maybe Measured
forall a. a -> Maybe a
Just (Maybe Double -> Maybe Double -> Measured
Measured (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
w) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
h)))
                mDims
          , nodeResizing = fromMaybe (nodeResizing n) mResizing
          , nodeWidth = case (setAttrs, mDims) of
              (SetAttributes
SetAttributesWidth, Just Dimensions
d) -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Dimensions -> Double
dimensionsWidth Dimensions
d)
              (SetAttributes
SetAttributesBoth, Just Dimensions
d) -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Dimensions -> Double
dimensionsWidth Dimensions
d)
              (SetAttributes, Maybe Dimensions)
_ -> Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeWidth Node n
n
          , nodeHeight = case (setAttrs, mDims) of
              (SetAttributes
SetAttributesHeight, Just Dimensions
d) -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Dimensions -> Double
dimensionsHeight Dimensions
d)
              (SetAttributes
SetAttributesBoth, Just Dimensions
d) -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Dimensions -> Double
dimensionsHeight Dimensions
d)
              (SetAttributes, Maybe Dimensions)
_ -> Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeHeight Node n
n
          }
    in case Maybe Dimensions
mDims of
         Maybe Dimensions
Nothing -> FlowModel n e
withDims
         Just Dimensions
dims -> FlowModel n e
withDims
           { fmNodeLookup =
               applyMeasurement
                 [ NodeMeasurement
                     { nmId = nid
                     , nmDimensions = dims
                     , nmHandleBounds = mHandleBounds
                     , nmPositionAbsolute = mPosAbs
                     }
                 ]
                 (fmNodeLookup withDims)
           }
  WireSelectionChange MisoString
nid Bool
selected ->
    MisoString -> (Node n -> Node n) -> FlowModel n e
onNode MisoString
nid ((Node n -> Node n) -> FlowModel n e)
-> (Node n -> Node n) -> FlowModel n e
forall a b. (a -> b) -> a -> b
$ \Node n
n -> Node n
n { nodeSelected = selected }
  WireRemoveChange MisoString
nid ->
    FlowModel n e
m { fmNodes = [ n | n <- fmNodes m, nodeId n /= nid ]
      , fmEdges =
          [ e | e <- fmEdges m, edgeSource e /= nid, edgeTarget e /= nid ]
      }
  where
    onNode :: MisoString -> (Node n -> Node n) -> FlowModel n e
onNode MisoString
nid Node n -> Node n
f =
      FlowModel n e
m { fmNodes =
            [ if nodeId n == nid then f n else n | n <- fmNodes m ]
        }
-----------------------------------------------------------------------------
-- | The scene 'flowView' draws for a model.
sceneFromModel :: FlowModel n e -> FlowScene n e
sceneFromModel :: forall n e. FlowModel n e -> FlowScene n e
sceneFromModel FlowModel {[Edge e]
[Node n]
Maybe Rect
Maybe FlowStore
Maybe MinimapConfig
ParentLookup n
NodeLookup n
ConnectionState n
Dimensions
Viewport
StoreOptions
PendingAttach
fmNodes :: forall n e. FlowModel n e -> [Node n]
fmEdges :: forall n e. FlowModel n e -> [Edge e]
fmNodeLookup :: forall n e. FlowModel n e -> NodeLookup n
fmParentLookup :: forall n e. FlowModel n e -> ParentLookup n
fmViewport :: forall n e. FlowModel n e -> Viewport
fmConnection :: forall n e. FlowModel n e -> ConnectionState n
fmStore :: forall n e. FlowModel n e -> Maybe FlowStore
fmPending :: forall n e. FlowModel n e -> PendingAttach
fmOptions :: forall n e. FlowModel n e -> StoreOptions
fmDimensions :: forall n e. FlowModel n e -> Dimensions
fmMinimap :: forall n e. FlowModel n e -> Maybe MinimapConfig
fmSelectionRect :: forall n e. FlowModel n e -> Maybe Rect
fmNodes :: [Node n]
fmEdges :: [Edge e]
fmNodeLookup :: NodeLookup n
fmParentLookup :: ParentLookup n
fmViewport :: Viewport
fmConnection :: ConnectionState n
fmStore :: Maybe FlowStore
fmPending :: PendingAttach
fmOptions :: StoreOptions
fmDimensions :: Dimensions
fmMinimap :: Maybe MinimapConfig
fmSelectionRect :: Maybe Rect
..} = FlowScene
  { sceneNodes :: [Node n]
sceneNodes = [Node n]
fmNodes
  , sceneNodeLookup :: NodeLookup n
sceneNodeLookup = NodeLookup n
fmNodeLookup
  , sceneEdges :: [Edge e]
sceneEdges = [Edge e]
fmEdges
  , sceneViewport :: Viewport
sceneViewport = Viewport
fmViewport
  , sceneConnection :: ConnectionState n
sceneConnection = ConnectionState n
fmConnection
  , sceneDimensions :: Dimensions
sceneDimensions = Dimensions
fmDimensions
  , sceneSelectionRect :: Maybe Rect
sceneSelectionRect = Maybe Rect
fmSelectionRect
  , sceneOptions :: StoreOptions
sceneOptions = StoreOptions
fmOptions
  }
-----------------------------------------------------------------------------
-- | Draw a model with a view config (see 'flowViewConfig').
viewFlow
  :: FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
  -> FlowModel n e
  -> View ctx (FlowModel n e) (FlowAction n e)
viewFlow :: forall ctx n e.
FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
-> FlowModel n e -> View ctx (FlowModel n e) (FlowAction n e)
viewFlow FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
cfg = FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
-> FlowScene n e -> View ctx (FlowModel n e) (FlowAction n e)
forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> View ctx model action
flowView FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
cfg (FlowScene n e -> View ctx (FlowModel n e) (FlowAction n e))
-> (FlowModel n e -> FlowScene n e)
-> FlowModel n e
-> View ctx (FlowModel n e) (FlowAction n e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlowModel n e -> FlowScene n e
forall n e. FlowModel n e -> FlowScene n e
sceneFromModel
-----------------------------------------------------------------------------
-- | A ready-to-mount flow. The view config passed to the customization
-- function is pre-wired: hooks, flow id and connection mode match the
-- store options, nodes render the given label view.
flowComponent
  :: Eq n
  => StoreOptions
  -> FlowSettings
  -> (n -> View ctx (FlowModel n e) (FlowAction n e))
  -- ^ node label
  -> (FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
      -> FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e))
  -- ^ view customization ('id' for the defaults)
  -> [Node n]
  -> [Edge e]
  -> Component ctx props (FlowModel n e) (FlowAction n e)
flowComponent :: forall n ctx e props.
Eq n =>
StoreOptions
-> FlowSettings
-> (n -> View ctx (FlowModel n e) (FlowAction n e))
-> (FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
    -> FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e))
-> [Node n]
-> [Edge e]
-> Component ctx props (FlowModel n e) (FlowAction n e)
flowComponent StoreOptions
options FlowSettings
settings n -> View ctx (FlowModel n e) (FlowAction n e)
label FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
-> FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
customize [Node n]
nodes [Edge e]
edges =
  (FlowModel n e
-> (FlowAction n e
    -> Effect ctx props (FlowModel n e) (FlowAction n e))
-> (ctx
    -> props
    -> FlowModel n e
    -> View ctx (FlowModel n e) (FlowAction n e))
-> Component ctx props (FlowModel n e) (FlowAction n e)
forall model action context props.
model
-> (action -> Effect context props model action)
-> (context -> props -> model -> View context model action)
-> Component context props model action
component (StoreOptions -> [Node n] -> [Edge e] -> FlowModel n e
forall n e.
Eq n =>
StoreOptions -> [Node n] -> [Edge e] -> FlowModel n e
flowModel StoreOptions
options [Node n]
nodes [Edge e]
edges) (FlowSettings
-> FlowAction n e
-> Effect ctx props (FlowModel n e) (FlowAction n e)
forall n e ctx props.
Eq n =>
FlowSettings
-> FlowAction n e
-> Effect ctx props (FlowModel n e) (FlowAction n e)
updateFlowWith FlowSettings
settings) ctx
-> props
-> FlowModel n e
-> View ctx (FlowModel n e) (FlowAction n e)
forall {p} {p}.
p
-> p -> FlowModel n e -> View ctx (FlowModel n e) (FlowAction n e)
view)
    { styles = [ flowCSS ] }
  where
    cfg :: FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
cfg = FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
-> FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
customize (FlowHooks (FlowAction n e)
-> (n -> View ctx (FlowModel n e) (FlowAction n e))
-> FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
forall action n ctx model e.
FlowHooks action
-> (n -> View ctx model action)
-> FlowViewConfig ctx n e model action
flowViewConfig FlowHooks (FlowAction n e)
forall n e. FlowHooks (FlowAction n e)
flowHooks n -> View ctx (FlowModel n e) (FlowAction n e)
label)
      { fvcFlowId = soFlowId options
      , fvcConnectionMode = soConnectionMode options
      }
    view :: p
-> p -> FlowModel n e -> View ctx (FlowModel n e) (FlowAction n e)
view p
_ctx p
_props = FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
-> FlowModel n e -> View ctx (FlowModel n e) (FlowAction n e)
forall ctx n e.
FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
-> FlowModel n e -> View ctx (FlowModel n e) (FlowAction n e)
viewFlow FlowViewConfig ctx n e (FlowModel n e) (FlowAction n e)
cfg
-----------------------------------------------------------------------------