-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Flow.View
-- License     :  BSD3-style (see the file LICENSE)
--
-- Pure views rendering the DOM contract that the miso-flow JavaScript
-- bridge (and the imperative @\@xyflow\/system@ modules behind it)
-- expects:
--
-- @
-- div.miso-flow[.dark]
--   svg.miso-flow__background          (optional dot grid)
--   div.miso-flow__pane
--     div.miso-flow__viewport.xyflow__viewport   (viewport transform)
--       svg.miso-flow__edges           (edge paths + marker defs)
--       div.miso-flow__nodes
--         div.miso-flow__node[data-id] (measured + dragged by the bridge)
--           …user content…
--           div.miso-flow__handle…     (connection handles)
--       svg.miso-flow__connectionline  (while connecting)
--   div.miso-flow__panel…              (controls, custom panels)
-- @
--
-- The selector contract: the bridge looks up @.miso-flow__pane@ and
-- @.xyflow__viewport@, measures handles via the @source@ \/ @target@
-- classes and @data-handleid@ \/ @data-handlepos@, and resolves
-- connections over @data-nodeid@ \/ @data-id@ and the @connectable@ \/
-- @connectablestart@ \/ @connectableend@ classes.
----------------------------------------------------------------------------
module Miso.Flow.View
  ( -- * Lifecycle hooks
    FlowHooks (..)
    -- * Configuration
  , FlowViewConfig (..)
  , flowViewConfig
  , NodeContentRenderer
    -- * Scene
  , FlowScene (..)
    -- * Views
  , flowView
  , defaultNodeContent
  , handleView
  , panelView
  , controlsView
    -- * Minimap
  , MinimapConfig (..)
  , defaultMinimapConfig
  , minimapView
  , minimapViewScaleFor
    -- * Node resizer
  , ResizerConfig (..)
  , defaultResizerConfig
  , nodeResizerView
    -- * Node toolbar
  , ToolbarConfig (..)
  , defaultToolbarConfig
  , nodeToolbarView
  , edgeToolbarView
    -- * Edge paths
  , edgePathFor
  , edgePositionFor
  , connectionPathFor
  ) where
-----------------------------------------------------------------------------
import qualified Data.Map.Strict as M
import           Data.Maybe (catMaybes, fromMaybe, isJust)
import           Prelude
-----------------------------------------------------------------------------
import           Miso.CSS (style_)
import           Miso.Effect (DOMRef)
import           Miso.JSON (Value, object, withObject, (.:), (.=))
import           Miso.Event
  ( Decoder (..)
  , DecodeTarget (DecodeTarget)
  , on
  , onBeforeDestroyed
  , onBeforeDestroyedWith
  , onCreatedWith
  )
import qualified Miso.Html as H
import qualified Miso.Html.Property as P
import           Miso.Property (key_, textProp)
import           Miso.String (MisoString)
import qualified Miso.Svg as S
import qualified Miso.Svg.Property as SP
import           Miso.Types (Attribute, View, text)
-----------------------------------------------------------------------------
import           Miso.Flow.Internal.Bridge (StoreOptions)
import           Miso.Flow.Internal.JSNum (jsShow)
import           Miso.Flow.Types
import           Miso.Flow.Utils.Edges
import           Miso.Flow.Utils.General
  ( getBoundsOfRects
  , getInternalNodeDimensions
  , internalNodeToRect
  )
import           Miso.Flow.Utils.Graph (getInternalNodesBounds)
import           Miso.Flow.Utils.Toolbar
  ( AlignX (AlignXCenter)
  , AlignY (AlignYCenter)
  , getEdgeToolbarTransform
  , getNodeToolbarTransform
  )
import           Miso.Flow.Utils.Marker (createMarkerIds, getMarkerId)
-----------------------------------------------------------------------------
-- | Actions dispatched from VDOM lifecycle events; the component layer
-- uses these to create the JavaScript store and attach gestures to the
-- elements as they appear.
data FlowHooks action = FlowHooks
  { forall action. FlowHooks action -> DOMRef -> action
hookFlowCreated :: DOMRef -> action
    -- ^ container inserted: create the store
  , forall action. FlowHooks action -> action
hookFlowBeforeDestroyed :: action
    -- ^ container about to leave: destroy the store
  , forall action. FlowHooks action -> MisoString -> DOMRef -> action
hookNodeCreated :: NodeId -> DOMRef -> action
    -- ^ node element inserted: observe + attach drag
  , forall action. FlowHooks action -> MisoString -> DOMRef -> action
hookNodeBeforeDestroyed :: NodeId -> DOMRef -> action
    -- ^ node element about to leave: unobserve + detach drag
  , forall action. FlowHooks action -> DOMRef -> action
hookHandleCreated :: DOMRef -> action
    -- ^ handle element inserted: attach connection gestures
  , forall action. FlowHooks action -> Maybe (MisoString -> action)
hookEdgeClick :: Maybe (EdgeId -> action)
    -- ^ optional: click on an edge's interaction path
  , forall action.
FlowHooks action -> Maybe (MisoString -> Bool -> action)
hookNodeClick :: Maybe (NodeId -> Bool -> action)
    -- ^ optional: plain click on a node; the 'Bool' is 'True' when a
    -- multi-selection modifier (shift\/meta\/ctrl) was held. Drags don't
    -- reach it — d3-drag suppresses the click after a real drag.
  , forall action.
FlowHooks action -> MisoString -> Value -> DOMRef -> action
hookResizerCreated :: NodeId -> Value -> DOMRef -> action
    -- ^ resize control inserted (the 'Value' carries the XYResizer
    -- parameters built by 'nodeResizerView')
  , forall action. FlowHooks action -> MisoString -> DOMRef -> action
hookResizerBeforeDestroyed :: NodeId -> DOMRef -> action
    -- ^ resize control about to leave
  , forall action.
FlowHooks action -> MinimapConfig -> DOMRef -> action
hookMinimapCreated :: MinimapConfig -> DOMRef -> action
    -- ^ minimap svg inserted: attach XYMinimap pan\/zoom
  , forall action. FlowHooks action -> DOMRef -> action
hookEdgeAnchorCreated :: DOMRef -> action
    -- ^ edge reconnect anchor inserted: attach the reconnect gesture
  }
-----------------------------------------------------------------------------
-- | Content rendered /inside/ the node wrapper element (the wrapper
-- itself — positioning, classes, lifecycle — is owned by 'flowView').
type NodeContentRenderer ctx n e model action
  = FlowViewConfig ctx n e model action
  -> Node n
  -> [View ctx model action]
-----------------------------------------------------------------------------
data FlowViewConfig ctx n e model action = FlowViewConfig
  { forall ctx n e model action.
FlowViewConfig ctx n e model action -> MisoString
fvcFlowId :: MisoString
    -- ^ must match 'Miso.Flow.Internal.Bridge.soFlowId'
  , forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcDark :: Bool
    -- ^ add the @dark@ class (see "Miso.Flow.Style")
  , forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionMode
fvcConnectionMode :: ConnectionMode
    -- ^ must match 'Miso.Flow.Internal.Bridge.soConnectionMode'
  , forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionLineType
fvcConnectionLineType :: ConnectionLineType
    -- ^ path style of the in-progress connection line
  , forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcShowBackground :: Bool
    -- ^ render the dot-grid background
  , forall ctx n e model action.
FlowViewConfig ctx n e model action
-> NodeContentRenderer ctx n e model action
fvcNodeContent :: NodeContentRenderer ctx n e model action
  , forall ctx n e model action.
FlowViewConfig ctx n e model action -> [Attribute model action]
fvcAttrs :: [Attribute model action]
    -- ^ extra attributes for the container (id, inline size, …)
  , forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcChildren :: FlowScene n e -> [View ctx model action]
    -- ^ overlays for the current scene: panels, controls, minimap, …
  , forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcViewportChildren :: FlowScene n e -> [View ctx model action]
    -- ^ overlays rendered /inside/ the transformed viewport (flow
    -- coordinates): edge toolbars, custom labels, …
  , forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcEdgesReconnectable :: Bool
    -- ^ render reconnect anchors on selected edges
  , forall ctx n e model action.
FlowViewConfig ctx n e model action -> FlowHooks action
fvcHooks :: FlowHooks action
  }
-----------------------------------------------------------------------------
-- | Config with xyflow-like defaults; nodes render their 'nodeData'
-- through the given label view.
flowViewConfig
  :: FlowHooks action
  -> (n -> View ctx model action)
  -- ^ node label
  -> FlowViewConfig ctx n e model action
flowViewConfig :: forall action n ctx model e.
FlowHooks action
-> (n -> View ctx model action)
-> FlowViewConfig ctx n e model action
flowViewConfig FlowHooks action
hooks n -> View ctx model action
label = FlowViewConfig
  { fvcFlowId :: MisoString
fvcFlowId = MisoString
"1"
  , fvcDark :: Bool
fvcDark = Bool
False
  , fvcConnectionMode :: ConnectionMode
fvcConnectionMode = ConnectionMode
ConnectionModeStrict
  , fvcConnectionLineType :: ConnectionLineType
fvcConnectionLineType = ConnectionLineType
ConnectionLineBezier
  , fvcShowBackground :: Bool
fvcShowBackground = Bool
True
  , fvcNodeContent :: NodeContentRenderer ctx n e model action
fvcNodeContent = (Node n -> View ctx model action)
-> NodeContentRenderer ctx n e model action
forall n ctx model action e.
(Node n -> View ctx model action)
-> NodeContentRenderer ctx n e model action
defaultNodeContent (n -> View ctx model action
label (n -> View ctx model action)
-> (Node n -> n) -> Node n -> View ctx model action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node n -> n
forall n. Node n -> n
nodeData)
  , fvcAttrs :: [Attribute model action]
fvcAttrs = []
  , fvcChildren :: FlowScene n e -> [View ctx model action]
fvcChildren = [View ctx model action] -> FlowScene n e -> [View ctx model action]
forall a b. a -> b -> a
const []
  , fvcViewportChildren :: FlowScene n e -> [View ctx model action]
fvcViewportChildren = [View ctx model action] -> FlowScene n e -> [View ctx model action]
forall a b. a -> b -> a
const []
  , fvcEdgesReconnectable :: Bool
fvcEdgesReconnectable = Bool
False
  , fvcHooks :: FlowHooks action
fvcHooks = FlowHooks action
hooks
  }
-----------------------------------------------------------------------------
-- | Everything 'flowView' draws in one frame.
data FlowScene n e = FlowScene
  { forall n e. FlowScene n e -> [Node n]
sceneNodes :: [Node n]
    -- ^ user nodes, in render order
  , forall n e. FlowScene n e -> NodeLookup n
sceneNodeLookup :: NodeLookup n
    -- ^ internals for 'sceneNodes' (absolute positions, z, measurements)
  , forall n e. FlowScene n e -> [Edge e]
sceneEdges :: [Edge e]
  , forall n e. FlowScene n e -> Viewport
sceneViewport :: Viewport
  , forall n e. FlowScene n e -> ConnectionState n
sceneConnection :: ConnectionState n
    -- ^ in-progress connection, if any
  , forall n e. FlowScene n e -> Dimensions
sceneDimensions :: Dimensions
    -- ^ container size as reported by the bridge (drives the minimap)
  , forall n e. FlowScene n e -> Maybe Rect
sceneSelectionRect :: Maybe Rect
    -- ^ in-progress selection box, in container coordinates
  , forall n e. FlowScene n e -> StoreOptions
sceneOptions :: StoreOptions
    -- ^ current store options (snapping, zoom limits, …)
  }
-----------------------------------------------------------------------------
-- | The full flow container.
flowView
  :: FlowViewConfig ctx n e model action
  -> FlowScene n e
  -> View ctx model action
flowView :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> View ctx model action
flowView cfg :: FlowViewConfig ctx n e model action
cfg@FlowViewConfig {Bool
[Attribute model action]
MisoString
ConnectionLineType
ConnectionMode
FlowHooks action
FlowScene n e -> [View ctx model action]
NodeContentRenderer ctx n e model action
fvcFlowId :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> MisoString
fvcDark :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcConnectionMode :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionMode
fvcConnectionLineType :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionLineType
fvcShowBackground :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcNodeContent :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> NodeContentRenderer ctx n e model action
fvcAttrs :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> [Attribute model action]
fvcChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcViewportChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcHooks :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> FlowHooks action
fvcFlowId :: MisoString
fvcDark :: Bool
fvcConnectionMode :: ConnectionMode
fvcConnectionLineType :: ConnectionLineType
fvcShowBackground :: Bool
fvcNodeContent :: NodeContentRenderer ctx n e model action
fvcAttrs :: [Attribute model action]
fvcChildren :: FlowScene n e -> [View ctx model action]
fvcViewportChildren :: FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: Bool
fvcHooks :: FlowHooks action
..} scene :: FlowScene n e
scene@FlowScene {[Edge e]
[Node n]
Maybe Rect
NodeLookup n
ConnectionState n
Dimensions
Viewport
StoreOptions
sceneNodes :: forall n e. FlowScene n e -> [Node n]
sceneNodeLookup :: forall n e. FlowScene n e -> NodeLookup n
sceneEdges :: forall n e. FlowScene n e -> [Edge e]
sceneViewport :: forall n e. FlowScene n e -> Viewport
sceneConnection :: forall n e. FlowScene n e -> ConnectionState n
sceneDimensions :: forall n e. FlowScene n e -> Dimensions
sceneSelectionRect :: forall n e. FlowScene n e -> Maybe Rect
sceneOptions :: forall n e. FlowScene n e -> StoreOptions
sceneNodes :: [Node n]
sceneNodeLookup :: NodeLookup n
sceneEdges :: [Edge e]
sceneViewport :: Viewport
sceneConnection :: ConnectionState n
sceneDimensions :: Dimensions
sceneSelectionRect :: Maybe Rect
sceneOptions :: StoreOptions
..} =
  [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
    ( [MisoString] -> Attribute model action
forall model action. [MisoString] -> Attribute model action
P.classes_ (MisoString
"miso-flow" MisoString -> [MisoString] -> [MisoString]
forall a. a -> [a] -> [a]
: [ MisoString
"dark" | Bool
fvcDark ])
    Attribute model action
-> [Attribute model action] -> [Attribute model action]
forall a. a -> [a] -> [a]
: (DOMRef -> action) -> Attribute model action
forall action model. (DOMRef -> action) -> Attribute model action
onCreatedWith (FlowHooks action -> DOMRef -> action
forall action. FlowHooks action -> DOMRef -> action
hookFlowCreated FlowHooks action
fvcHooks)
    Attribute model action
-> [Attribute model action] -> [Attribute model action]
forall a. a -> [a] -> [a]
: action -> Attribute model action
forall action model. action -> Attribute model action
onBeforeDestroyed (FlowHooks action -> action
forall action. FlowHooks action -> action
hookFlowBeforeDestroyed FlowHooks action
fvcHooks)
    Attribute model action
-> [Attribute model action] -> [Attribute model action]
forall a. a -> [a] -> [a]
: [Attribute model action]
fvcAttrs
    )
    ( [ MisoString -> Viewport -> View ctx model action
forall ctx model action.
MisoString -> Viewport -> View ctx model action
backgroundView MisoString
fvcFlowId Viewport
sceneViewport | Bool
fvcShowBackground ]
   [View ctx model action]
-> [View ctx model action] -> [View ctx model action]
forall a. Semigroup a => a -> a -> a
<> [ [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
          [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__pane" ]
          ( [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
              [ [MisoString] -> Attribute model action
forall model action. [MisoString] -> Attribute model action
P.classes_ [ MisoString
"miso-flow__viewport", MisoString
"xyflow__viewport" ]
              , [Style] -> Attribute model action
forall model action. [Style] -> Attribute model action
style_ [ (MisoString
"transform", Viewport -> MisoString
viewportTransform Viewport
sceneViewport) ]
              ]
              ( [ FlowViewConfig ctx n e model action
-> FlowScene n e -> View ctx model action
forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> View ctx model action
edgesView FlowViewConfig ctx n e model action
cfg FlowScene n e
scene
                , [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
                    [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__nodes" ]
                    ((Node n -> View ctx model action)
-> [Node n] -> [View ctx model action]
forall a b. (a -> b) -> [a] -> [b]
map (FlowViewConfig ctx n e model action
-> FlowScene n e -> Node n -> View ctx model action
forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> Node n -> View ctx model action
nodeView FlowViewConfig ctx n e model action
cfg FlowScene n e
scene) [Node n]
sceneNodes)
                ]
             [View ctx model action]
-> [View ctx model action] -> [View ctx model action]
forall a. Semigroup a => a -> a -> a
<> FlowViewConfig ctx n e model action
-> ConnectionState n -> [View ctx model action]
forall ctx n e model action.
FlowViewConfig ctx n e model action
-> ConnectionState n -> [View ctx model action]
connectionLineView FlowViewConfig ctx n e model action
cfg ConnectionState n
sceneConnection
             [View ctx model action]
-> [View ctx model action] -> [View ctx model action]
forall a. Semigroup a => a -> a -> a
<> FlowScene n e -> [View ctx model action]
fvcViewportChildren FlowScene n e
scene
              )
          View ctx model action
-> [View ctx model action] -> [View ctx model action]
forall a. a -> [a] -> [a]
: Maybe Rect -> [View ctx model action]
forall ctx model action. Maybe Rect -> [View ctx model action]
selectionRectView Maybe Rect
sceneSelectionRect
          )
      ]
   [View ctx model action]
-> [View ctx model action] -> [View ctx model action]
forall a. Semigroup a => a -> a -> a
<> FlowScene n e -> [View ctx model action]
fvcChildren FlowScene n e
scene
    )
-----------------------------------------------------------------------------
viewportTransform :: Viewport -> MisoString
viewportTransform :: Viewport -> MisoString
viewportTransform Viewport {Double
viewportX :: Double
viewportY :: Double
viewportZoom :: Double
viewportX :: Viewport -> Double
viewportY :: Viewport -> Double
viewportZoom :: Viewport -> Double
..} = [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat
  [ MisoString
"translate(", Double -> MisoString
jsShow Double
viewportX, MisoString
"px, ", Double -> MisoString
jsShow Double
viewportY, MisoString
"px) "
  , MisoString
"scale(", Double -> MisoString
jsShow Double
viewportZoom, MisoString
")"
  ]
-----------------------------------------------------------------------------
-- * Nodes
-----------------------------------------------------------------------------
nodeView
  :: FlowViewConfig ctx n e model action
  -> FlowScene n e
  -> Node n
  -> View ctx model action
nodeView :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> Node n -> View ctx model action
nodeView cfg :: FlowViewConfig ctx n e model action
cfg@FlowViewConfig {Bool
[Attribute model action]
MisoString
ConnectionLineType
ConnectionMode
FlowHooks action
FlowScene n e -> [View ctx model action]
NodeContentRenderer ctx n e model action
fvcFlowId :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> MisoString
fvcDark :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcConnectionMode :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionMode
fvcConnectionLineType :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionLineType
fvcShowBackground :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcNodeContent :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> NodeContentRenderer ctx n e model action
fvcAttrs :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> [Attribute model action]
fvcChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcViewportChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcHooks :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> FlowHooks action
fvcFlowId :: MisoString
fvcDark :: Bool
fvcConnectionMode :: ConnectionMode
fvcConnectionLineType :: ConnectionLineType
fvcShowBackground :: Bool
fvcNodeContent :: NodeContentRenderer ctx n e model action
fvcAttrs :: [Attribute model action]
fvcChildren :: FlowScene n e -> [View ctx model action]
fvcViewportChildren :: FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: Bool
fvcHooks :: FlowHooks action
..} FlowScene {[Edge e]
[Node n]
Maybe Rect
NodeLookup n
ConnectionState n
Dimensions
Viewport
StoreOptions
sceneNodes :: forall n e. FlowScene n e -> [Node n]
sceneNodeLookup :: forall n e. FlowScene n e -> NodeLookup n
sceneEdges :: forall n e. FlowScene n e -> [Edge e]
sceneViewport :: forall n e. FlowScene n e -> Viewport
sceneConnection :: forall n e. FlowScene n e -> ConnectionState n
sceneDimensions :: forall n e. FlowScene n e -> Dimensions
sceneSelectionRect :: forall n e. FlowScene n e -> Maybe Rect
sceneOptions :: forall n e. FlowScene n e -> StoreOptions
sceneNodes :: [Node n]
sceneNodeLookup :: NodeLookup n
sceneEdges :: [Edge e]
sceneViewport :: Viewport
sceneConnection :: ConnectionState n
sceneDimensions :: Dimensions
sceneSelectionRect :: Maybe Rect
sceneOptions :: StoreOptions
..} Node n
n
  | Node n -> Bool
forall n. Node n -> Bool
nodeHidden Node n
n =
      [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
        [ MisoString -> Attribute model action
forall key model action. ToKey key => key -> Attribute model action
key_ (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n)
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__node"
        , MisoString -> MisoString -> Attribute model action
forall model action.
MisoString -> MisoString -> Attribute model action
textProp MisoString
"data-id" (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n)
        , Bool -> Attribute model action
forall model action. Bool -> Attribute model action
P.hidden_ Bool
True
        ]
        []
  | Bool
otherwise =
      [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
        ( [ MisoString -> Attribute model action
forall key model action. ToKey key => key -> Attribute model action
key_ (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n)
          , [MisoString] -> Attribute model action
forall model action. [MisoString] -> Attribute model action
P.classes_ ([MisoString] -> Attribute model action)
-> [MisoString] -> Attribute model action
forall a b. (a -> b) -> a -> b
$ [Maybe MisoString] -> [MisoString]
forall a. [Maybe a] -> [a]
catMaybes
              [ MisoString -> Maybe MisoString
forall a. a -> Maybe a
Just MisoString
"miso-flow__node"
              , (MisoString
"miso-flow__node-" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<>) (MisoString -> MisoString) -> Maybe MisoString -> Maybe MisoString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node n -> Maybe MisoString
forall n. Node n -> Maybe MisoString
nodeType Node n
n
              , Bool -> MisoString -> Maybe MisoString
forall a. Bool -> a -> Maybe a
justWhen (Node n -> Bool
forall n. Node n -> Bool
nodeSelected Node n
n) MisoString
"selected"
              , Bool -> MisoString -> Maybe MisoString
forall a. Bool -> a -> Maybe a
justWhen (Node n -> Bool
forall n. Node n -> Bool
nodeDragging Node n
n) MisoString
"dragging"
              , Bool -> MisoString -> Maybe MisoString
forall a. Bool -> a -> Maybe a
justWhen Bool
draggable MisoString
"nopan"
              ]
          , MisoString -> MisoString -> Attribute model action
forall model action.
MisoString -> MisoString -> Attribute model action
textProp MisoString
"data-id" (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n)
            -- always set explicitly: miso clears removed boolean
            -- properties via setAttribute(name, ''), which would leave
            -- a previously hidden node hidden
          , Bool -> Attribute model action
forall model action. Bool -> Attribute model action
P.hidden_ Bool
False
          , [Style] -> Attribute model action
forall model action. [Style] -> Attribute model action
style_ [Style]
nodeStyles
          , (DOMRef -> action) -> Attribute model action
forall action model. (DOMRef -> action) -> Attribute model action
onCreatedWith (FlowHooks action -> MisoString -> DOMRef -> action
forall action. FlowHooks action -> MisoString -> DOMRef -> action
hookNodeCreated FlowHooks action
fvcHooks (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n))
          , (DOMRef -> action) -> Attribute model action
forall action model. (DOMRef -> action) -> Attribute model action
onBeforeDestroyedWith (FlowHooks action -> MisoString -> DOMRef -> action
forall action. FlowHooks action -> MisoString -> DOMRef -> action
hookNodeBeforeDestroyed FlowHooks action
fvcHooks (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n))
          ]
       [Attribute model action]
-> [Attribute model action] -> [Attribute model action]
forall a. Semigroup a => a -> a -> a
<> [ MisoString
-> Decoder Bool
-> (Bool -> model -> DOMRef -> action)
-> Attribute model action
forall result model action.
MisoString
-> Decoder result
-> (result -> model -> DOMRef -> action)
-> Attribute model action
on MisoString
"click" Decoder Bool
multiModifierDecoder (\Bool
multi model
_ DOMRef
_ -> MisoString -> Bool -> action
click (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n) Bool
multi)
          | Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Node n -> Maybe Bool
forall n. Node n -> Maybe Bool
nodeSelectable Node n
n)
          , Just MisoString -> Bool -> action
click <- [ FlowHooks action -> Maybe (MisoString -> Bool -> action)
forall action.
FlowHooks action -> Maybe (MisoString -> Bool -> action)
hookNodeClick FlowHooks action
fvcHooks ]
          ]
        )
        (NodeContentRenderer ctx n e model action
fvcNodeContent FlowViewConfig ctx n e model action
cfg Node n
n)
  where
    draggable :: Bool
draggable = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Node n -> Maybe Bool
forall n. Node n -> Maybe Bool
nodeDraggable Node n
n)
    internal :: Maybe (InternalNode n)
internal = MisoString -> NodeLookup n -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n) NodeLookup n
sceneNodeLookup
    positionAbsolute :: XYPosition
positionAbsolute = XYPosition
-> (InternalNode n -> XYPosition)
-> Maybe (InternalNode n)
-> XYPosition
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Node n -> XYPosition
forall n. Node n -> XYPosition
nodePosition Node n
n) InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute Maybe (InternalNode n)
internal
    measured :: Bool
measured = Bool -> (InternalNode n -> Bool) -> Maybe (InternalNode n) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Maybe Dimensions -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Dimensions -> Bool)
-> (InternalNode n -> Maybe Dimensions) -> InternalNode n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Measured -> Maybe Dimensions
measuredToDimensions (Measured -> Maybe Dimensions)
-> (InternalNode n -> Measured)
-> InternalNode n
-> Maybe Dimensions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured) Maybe (InternalNode n)
internal
    zIndex :: Double
zIndex = Double
-> (InternalNode n -> Double) -> Maybe (InternalNode n) -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 InternalNode n -> Double
forall n. InternalNode n -> Double
internalZ Maybe (InternalNode n)
internal
    nodeStyles :: [Style]
nodeStyles = [Maybe Style] -> [Style]
forall a. [Maybe a] -> [a]
catMaybes
      [ Style -> Maybe Style
forall a. a -> Maybe a
Just
          ( MisoString
"transform"
          , [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat
              [ MisoString
"translate(", Double -> MisoString
jsShow (XYPosition -> Double
xyX XYPosition
positionAbsolute), MisoString
"px, "
              , Double -> MisoString
jsShow (XYPosition -> Double
xyY XYPosition
positionAbsolute), MisoString
"px)"
              ]
          )
      , Style -> Maybe Style
forall a. a -> Maybe a
Just (MisoString
"z-index", Double -> MisoString
jsShow Double
zIndex)
      , (\Double
w -> (MisoString
"width", Double -> MisoString
jsShow Double
w MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"px")) (Double -> Style) -> Maybe Double -> Maybe Style
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeWidth Node n
n
      , (\Double
h -> (MisoString
"height", Double -> MisoString
jsShow Double
h MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"px")) (Double -> Style) -> Maybe Double -> Maybe Style
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeHeight Node n
n
        -- hide until the bridge has measured it, to avoid a (0,0) flash
      , Bool -> Style -> Maybe Style
forall a. Bool -> a -> Maybe a
justWhen (Bool -> Bool
not Bool
measured) (MisoString
"visibility", MisoString
"hidden")
      ]
-----------------------------------------------------------------------------
justWhen :: Bool -> a -> Maybe a
justWhen :: forall a. Bool -> a -> Maybe a
justWhen Bool
b a
a = if Bool
b then a -> Maybe a
forall a. a -> Maybe a
Just a
a else Maybe a
forall a. Maybe a
Nothing
-----------------------------------------------------------------------------
-- | Default node content: a target handle, the label, a source handle.
defaultNodeContent
  :: (Node n -> View ctx model action)
  -- ^ label
  -> NodeContentRenderer ctx n e model action
defaultNodeContent :: forall n ctx model action e.
(Node n -> View ctx model action)
-> NodeContentRenderer ctx n e model action
defaultNodeContent Node n -> View ctx model action
label FlowViewConfig ctx n e model action
cfg Node n
n =
  [ FlowViewConfig ctx n e model action
-> Node n
-> HandleType
-> Position
-> Maybe MisoString
-> View ctx model action
forall ctx n e model action.
FlowViewConfig ctx n e model action
-> Node n
-> HandleType
-> Position
-> Maybe MisoString
-> View ctx model action
handleView FlowViewConfig ctx n e model action
cfg Node n
n HandleType
TargetHandle (Position -> Maybe Position -> Position
forall a. a -> Maybe a -> a
fromMaybe Position
PositionTop (Node n -> Maybe Position
forall n. Node n -> Maybe Position
nodeTargetPosition Node n
n)) Maybe MisoString
forall a. Maybe a
Nothing
  , [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_ [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__node-default" ] [ Node n -> View ctx model action
label Node n
n ]
  , FlowViewConfig ctx n e model action
-> Node n
-> HandleType
-> Position
-> Maybe MisoString
-> View ctx model action
forall ctx n e model action.
FlowViewConfig ctx n e model action
-> Node n
-> HandleType
-> Position
-> Maybe MisoString
-> View ctx model action
handleView FlowViewConfig ctx n e model action
cfg Node n
n HandleType
SourceHandle (Position -> Maybe Position -> Position
forall a. a -> Maybe a -> a
fromMaybe Position
PositionBottom (Node n -> Maybe Position
forall n. Node n -> Maybe Position
nodeSourcePosition Node n
n)) Maybe MisoString
forall a. Maybe a
Nothing
  ]
-----------------------------------------------------------------------------
-- | A connection handle, carrying all attributes the gesture system
-- reads ('data-id' mirrors the TS template including its @null@ for a
-- missing handle id).
handleView
  :: FlowViewConfig ctx n e model action
  -> Node n
  -> HandleType
  -> Position
  -> Maybe MisoString
  -- ^ handle id (for multi-handle nodes)
  -> View ctx model action
handleView :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> Node n
-> HandleType
-> Position
-> Maybe MisoString
-> View ctx model action
handleView FlowViewConfig {Bool
[Attribute model action]
MisoString
ConnectionLineType
ConnectionMode
FlowHooks action
FlowScene n e -> [View ctx model action]
NodeContentRenderer ctx n e model action
fvcFlowId :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> MisoString
fvcDark :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcConnectionMode :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionMode
fvcConnectionLineType :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionLineType
fvcShowBackground :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcNodeContent :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> NodeContentRenderer ctx n e model action
fvcAttrs :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> [Attribute model action]
fvcChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcViewportChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcHooks :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> FlowHooks action
fvcFlowId :: MisoString
fvcDark :: Bool
fvcConnectionMode :: ConnectionMode
fvcConnectionLineType :: ConnectionLineType
fvcShowBackground :: Bool
fvcNodeContent :: NodeContentRenderer ctx n e model action
fvcAttrs :: [Attribute model action]
fvcChildren :: FlowScene n e -> [View ctx model action]
fvcViewportChildren :: FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: Bool
fvcHooks :: FlowHooks action
..} Node n
n HandleType
handleType Position
position Maybe MisoString
handleId =
  [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
    [ [MisoString] -> Attribute model action
forall model action. [MisoString] -> Attribute model action
P.classes_ ([MisoString] -> Attribute model action)
-> [MisoString] -> Attribute model action
forall a b. (a -> b) -> a -> b
$
        [ MisoString
"miso-flow__handle"
        , MisoString
"miso-flow__handle-" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Position -> MisoString
positionToText Position
position
        , HandleType -> MisoString
handleTypeToText HandleType
handleType
        , MisoString
"nodrag"
        , MisoString
"nopan"
        ]
     [MisoString] -> [MisoString] -> [MisoString]
forall a. Semigroup a => a -> a -> a
<> (if Bool
connectable then [ MisoString
"connectable", MisoString
"connectablestart", MisoString
"connectableend" ] else [])
    , MisoString -> MisoString -> Attribute model action
forall model action.
MisoString -> MisoString -> Attribute model action
textProp MisoString
"data-id" (MisoString -> Attribute model action)
-> MisoString -> Attribute model action
forall a b. (a -> b) -> a -> b
$ [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat
        [ MisoString
fvcFlowId, MisoString
"-", Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n, MisoString
"-"
        , MisoString -> Maybe MisoString -> MisoString
forall a. a -> Maybe a -> a
fromMaybe MisoString
"null" Maybe MisoString
handleId, MisoString
"-"
        , HandleType -> MisoString
handleTypeToText HandleType
handleType
        ]
    , MisoString -> MisoString -> Attribute model action
forall model action.
MisoString -> MisoString -> Attribute model action
textProp MisoString
"data-nodeid" (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n)
    , MisoString -> MisoString -> Attribute model action
forall model action.
MisoString -> MisoString -> Attribute model action
textProp MisoString
"data-handlepos" (Position -> MisoString
positionToText Position
position)
    , Attribute model action
-> (MisoString -> Attribute model action)
-> Maybe MisoString
-> Attribute model action
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([MisoString] -> Attribute model action
forall model action. [MisoString] -> Attribute model action
P.classes_ []) (MisoString -> MisoString -> Attribute model action
forall model action.
MisoString -> MisoString -> Attribute model action
textProp MisoString
"data-handleid") Maybe MisoString
handleId
    , (DOMRef -> action) -> Attribute model action
forall action model. (DOMRef -> action) -> Attribute model action
onCreatedWith (FlowHooks action -> DOMRef -> action
forall action. FlowHooks action -> DOMRef -> action
hookHandleCreated FlowHooks action
fvcHooks)
    ]
    []
  where
    connectable :: Bool
connectable = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Node n -> Maybe Bool
forall n. Node n -> Maybe Bool
nodeConnectable Node n
n)
-----------------------------------------------------------------------------
-- * Edges
-----------------------------------------------------------------------------
edgesView
  :: FlowViewConfig ctx n e model action
  -> FlowScene n e
  -> View ctx model action
edgesView :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> View ctx model action
edgesView FlowViewConfig ctx n e model action
cfg FlowScene {[Edge e]
[Node n]
Maybe Rect
NodeLookup n
ConnectionState n
Dimensions
Viewport
StoreOptions
sceneNodes :: forall n e. FlowScene n e -> [Node n]
sceneNodeLookup :: forall n e. FlowScene n e -> NodeLookup n
sceneEdges :: forall n e. FlowScene n e -> [Edge e]
sceneViewport :: forall n e. FlowScene n e -> Viewport
sceneConnection :: forall n e. FlowScene n e -> ConnectionState n
sceneDimensions :: forall n e. FlowScene n e -> Dimensions
sceneSelectionRect :: forall n e. FlowScene n e -> Maybe Rect
sceneOptions :: forall n e. FlowScene n e -> StoreOptions
sceneNodes :: [Node n]
sceneNodeLookup :: NodeLookup n
sceneEdges :: [Edge e]
sceneViewport :: Viewport
sceneConnection :: ConnectionState n
sceneDimensions :: Dimensions
sceneSelectionRect :: Maybe Rect
sceneOptions :: StoreOptions
..} =
  [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
S.svg_
    [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__edges" ]
    ( MisoString -> [Edge e] -> View ctx model action
forall e ctx model action.
MisoString -> [Edge e] -> View ctx model action
markerDefs (FlowViewConfig ctx n e model action -> MisoString
forall ctx n e model action.
FlowViewConfig ctx n e model action -> MisoString
fvcFlowId FlowViewConfig ctx n e model action
cfg) [Edge e]
sceneEdges
    View ctx model action
-> [View ctx model action] -> [View ctx model action]
forall a. a -> [a] -> [a]
: (Edge e -> View ctx model action)
-> [Edge e] -> [View ctx model action]
forall a b. (a -> b) -> [a] -> [b]
map (FlowViewConfig ctx n e model action
-> NodeLookup n -> Edge e -> View ctx model action
forall ctx n e model action.
FlowViewConfig ctx n e model action
-> NodeLookup n -> Edge e -> View ctx model action
edgeView FlowViewConfig ctx n e model action
cfg NodeLookup n
sceneNodeLookup) ((Edge e -> Bool) -> [Edge e] -> [Edge e]
forall a. (a -> Bool) -> [a] -> [a]
filter Edge e -> Bool
forall {e}. Edge e -> Bool
visible [Edge e]
sceneEdges)
    )
  where
    hiddenNode :: MisoString -> Bool
hiddenNode MisoString
nid =
      Bool -> (InternalNode n -> Bool) -> Maybe (InternalNode n) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Node n -> Bool
forall n. Node n -> Bool
nodeHidden (Node n -> Bool)
-> (InternalNode n -> Node n) -> InternalNode n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUserNode) (MisoString -> NodeLookup n -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MisoString
nid NodeLookup n
sceneNodeLookup)
    visible :: Edge e -> Bool
visible Edge e
e =
      Bool -> Bool
not (Edge e -> Bool
forall {e}. Edge e -> Bool
edgeHidden Edge e
e)
        Bool -> Bool -> Bool
&& Bool -> Bool
not (MisoString -> Bool
hiddenNode (Edge e -> MisoString
forall e. Edge e -> MisoString
edgeSource Edge e
e))
        Bool -> Bool -> Bool
&& Bool -> Bool
not (MisoString -> Bool
hiddenNode (Edge e -> MisoString
forall e. Edge e -> MisoString
edgeTarget Edge e
e))
-----------------------------------------------------------------------------
edgeView
  :: FlowViewConfig ctx n e model action
  -> NodeLookup n
  -> Edge e
  -> View ctx model action
edgeView :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> NodeLookup n -> Edge e -> View ctx model action
edgeView FlowViewConfig {Bool
[Attribute model action]
MisoString
ConnectionLineType
ConnectionMode
FlowHooks action
FlowScene n e -> [View ctx model action]
NodeContentRenderer ctx n e model action
fvcFlowId :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> MisoString
fvcDark :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcConnectionMode :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionMode
fvcConnectionLineType :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionLineType
fvcShowBackground :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcNodeContent :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> NodeContentRenderer ctx n e model action
fvcAttrs :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> [Attribute model action]
fvcChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcViewportChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcHooks :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> FlowHooks action
fvcFlowId :: MisoString
fvcDark :: Bool
fvcConnectionMode :: ConnectionMode
fvcConnectionLineType :: ConnectionLineType
fvcShowBackground :: Bool
fvcNodeContent :: NodeContentRenderer ctx n e model action
fvcAttrs :: [Attribute model action]
fvcChildren :: FlowScene n e -> [View ctx model action]
fvcViewportChildren :: FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: Bool
fvcHooks :: FlowHooks action
..} NodeLookup n
nodeLookup Edge e
e =
  [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
S.g_
    [ MisoString -> Attribute model action
forall key model action. ToKey key => key -> Attribute model action
key_ (Edge e -> MisoString
forall e. Edge e -> MisoString
edgeId Edge e
e)
    , [MisoString] -> Attribute model action
forall model action. [MisoString] -> Attribute model action
P.classes_ ([MisoString] -> Attribute model action)
-> [MisoString] -> Attribute model action
forall a b. (a -> b) -> a -> b
$ [Maybe MisoString] -> [MisoString]
forall a. [Maybe a] -> [a]
catMaybes
        [ MisoString -> Maybe MisoString
forall a. a -> Maybe a
Just MisoString
"miso-flow__edge"
        , (MisoString
"miso-flow__edge-" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<>) (MisoString -> MisoString) -> Maybe MisoString -> Maybe MisoString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Edge e -> Maybe MisoString
forall e. Edge e -> Maybe MisoString
edgeType Edge e
e
        , Bool -> MisoString -> Maybe MisoString
forall a. Bool -> a -> Maybe a
justWhen (Edge e -> Bool
forall {e}. Edge e -> Bool
edgeSelected Edge e
e) MisoString
"selected"
        , Bool -> MisoString -> Maybe MisoString
forall a. Bool -> a -> Maybe a
justWhen (Edge e -> Bool
forall {e}. Edge e -> Bool
edgeAnimated Edge e
e) MisoString
"animated"
        ]
    ]
    ( case ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePath
forall n e.
ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePath
edgePathFor ConnectionMode
fvcConnectionMode NodeLookup n
nodeLookup Edge e
e of
        Maybe EdgePath
Nothing -> []
        Just EdgePath
ep ->
          [ [Attribute model action] -> View ctx model action
forall model action context.
[Attribute model action] -> View context model action
S.path_
              ( [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__edge-path"
                , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.d_ (EdgePath -> MisoString
edgePath EdgePath
ep)
                ]
             [Attribute model action]
-> [Attribute model action] -> [Attribute model action]
forall a. Semigroup a => a -> a -> a
<> (MisoString -> Attribute model action)
-> Maybe EdgeMarkerType -> [Attribute model action]
forall {a}. (MisoString -> a) -> Maybe EdgeMarkerType -> [a]
markerAttr MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.markerStart_ (Edge e -> Maybe EdgeMarkerType
forall e. Edge e -> Maybe EdgeMarkerType
edgeMarkerStart Edge e
e)
             [Attribute model action]
-> [Attribute model action] -> [Attribute model action]
forall a. Semigroup a => a -> a -> a
<> (MisoString -> Attribute model action)
-> Maybe EdgeMarkerType -> [Attribute model action]
forall {a}. (MisoString -> a) -> Maybe EdgeMarkerType -> [a]
markerAttr MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.markerEnd_ (Edge e -> Maybe EdgeMarkerType
forall e. Edge e -> Maybe EdgeMarkerType
edgeMarkerEnd Edge e
e)
              )
          , [Attribute model action] -> View ctx model action
forall model action context.
[Attribute model action] -> View context model action
S.path_
              ( [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__edge-interaction"
                , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.d_ (EdgePath -> MisoString
edgePath EdgePath
ep)
                , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.strokeWidth_ (Double -> MisoString
jsShow Double
interactionWidth)
                ]
             [Attribute model action]
-> [Attribute model action] -> [Attribute model action]
forall a. Semigroup a => a -> a -> a
<> [ action -> Attribute model action
forall action model. action -> Attribute model action
H.onClick (MisoString -> action
click (Edge e -> MisoString
forall e. Edge e -> MisoString
edgeId Edge e
e))
                | Just MisoString -> action
click <- [ FlowHooks action -> Maybe (MisoString -> action)
forall action. FlowHooks action -> Maybe (MisoString -> action)
hookEdgeClick FlowHooks action
fvcHooks ]
                ]
              )
          ]
          [View ctx model action]
-> [View ctx model action] -> [View ctx model action]
forall a. Semigroup a => a -> a -> a
<> ( case ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePosition
forall n e.
ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePosition
edgePositionFor ConnectionMode
fvcConnectionMode NodeLookup n
nodeLookup Edge e
e of
                 Just EdgePosition
epos | Bool
reconnectable ->
                   [ MisoString -> Double -> Double -> Position -> View ctx model action
forall {context} {model}.
MisoString
-> Double -> Double -> Position -> View context model action
edgeAnchor MisoString
"source" (EdgePosition -> Double
epSourceX EdgePosition
epos) (EdgePosition -> Double
epSourceY EdgePosition
epos) (EdgePosition -> Position
epSourcePosition EdgePosition
epos)
                   , MisoString -> Double -> Double -> Position -> View ctx model action
forall {context} {model}.
MisoString
-> Double -> Double -> Position -> View context model action
edgeAnchor MisoString
"target" (EdgePosition -> Double
epTargetX EdgePosition
epos) (EdgePosition -> Double
epTargetY EdgePosition
epos) (EdgePosition -> Position
epTargetPosition EdgePosition
epos)
                   ]
                 Maybe EdgePosition
_ -> []
             )
    )
  where
    interactionWidth :: Double
interactionWidth = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
20 (Edge e -> Maybe Double
forall e. Edge e -> Maybe Double
edgeInteractionWidth Edge e
e)
    reconnectable :: Bool
reconnectable = Bool
fvcEdgesReconnectable Bool -> Bool -> Bool
&& Edge e -> Bool
forall {e}. Edge e -> Bool
edgeSelected Edge e
e
    anchorRadius :: Double
anchorRadius = Double
10 :: Double
    -- port of the framework packages' EdgeAnchor: a circle shifted
    -- towards the outside of the handle
    edgeAnchor :: MisoString
-> Double -> Double -> Position -> View context model action
edgeAnchor MisoString
anchorType Double
cx Double
cy Position
position =
      [Attribute model action] -> View context model action
forall model action context.
[Attribute model action] -> View context model action
S.circle_
        [ [MisoString] -> Attribute model action
forall model action. [MisoString] -> Attribute model action
P.classes_
            [ MisoString
"miso-flow__edge-anchor"
            , MisoString
"miso-flow__edge-anchor-" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
anchorType
            , MisoString
"nodrag"
            , MisoString
"nopan"
            ]
        , MisoString -> MisoString -> Attribute model action
forall model action.
MisoString -> MisoString -> Attribute model action
textProp MisoString
"data-edgeid" (Edge e -> MisoString
forall e. Edge e -> MisoString
edgeId Edge e
e)
        , MisoString -> MisoString -> Attribute model action
forall model action.
MisoString -> MisoString -> Attribute model action
textProp MisoString
"data-anchortype" MisoString
anchorType
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.cx_ (Double -> MisoString
jsShow (Double -> Position -> Position -> Position -> Double
forall {a}. Eq a => Double -> a -> a -> a -> Double
shiftAxis Double
cx Position
PositionLeft Position
PositionRight Position
position))
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.cy_ (Double -> MisoString
jsShow (Double -> Position -> Position -> Position -> Double
forall {a}. Eq a => Double -> a -> a -> a -> Double
shiftAxis Double
cy Position
PositionTop Position
PositionBottom Position
position))
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.r_ (Double -> MisoString
jsShow Double
anchorRadius)
        , (DOMRef -> action) -> Attribute model action
forall action model. (DOMRef -> action) -> Attribute model action
onCreatedWith (FlowHooks action -> DOMRef -> action
forall action. FlowHooks action -> DOMRef -> action
hookEdgeAnchorCreated FlowHooks action
fvcHooks)
        ]
    shiftAxis :: Double -> a -> a -> a -> Double
shiftAxis Double
v a
neg a
pos a
position
      | a
position a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
neg = Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
anchorRadius
      | a
position a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
pos = Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
anchorRadius
      | Bool
otherwise = Double
v
    markerAttr :: (MisoString -> a) -> Maybe EdgeMarkerType -> [a]
markerAttr MisoString -> a
attr = \case
      Maybe EdgeMarkerType
Nothing -> []
      Just EdgeMarkerType
m -> [ MisoString -> a
attr (MisoString
"url(#" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Maybe EdgeMarkerType -> Maybe MisoString -> MisoString
getMarkerId (EdgeMarkerType -> Maybe EdgeMarkerType
forall a. a -> Maybe a
Just EdgeMarkerType
m) (MisoString -> Maybe MisoString
forall a. a -> Maybe a
Just MisoString
fvcFlowId) MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
")") ]
-----------------------------------------------------------------------------
-- * Node toolbar
-----------------------------------------------------------------------------
data ToolbarConfig = ToolbarConfig
  { ToolbarConfig -> Position
tbPosition :: !Position
  , ToolbarConfig -> Double
tbOffset :: !Double
  , ToolbarConfig -> Align
tbAlign :: !Align
  } deriving (Int -> ToolbarConfig -> ShowS
[ToolbarConfig] -> ShowS
ToolbarConfig -> String
(Int -> ToolbarConfig -> ShowS)
-> (ToolbarConfig -> String)
-> ([ToolbarConfig] -> ShowS)
-> Show ToolbarConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ToolbarConfig -> ShowS
showsPrec :: Int -> ToolbarConfig -> ShowS
$cshow :: ToolbarConfig -> String
show :: ToolbarConfig -> String
$cshowList :: [ToolbarConfig] -> ShowS
showList :: [ToolbarConfig] -> ShowS
Show, ToolbarConfig -> ToolbarConfig -> Bool
(ToolbarConfig -> ToolbarConfig -> Bool)
-> (ToolbarConfig -> ToolbarConfig -> Bool) -> Eq ToolbarConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ToolbarConfig -> ToolbarConfig -> Bool
== :: ToolbarConfig -> ToolbarConfig -> Bool
$c/= :: ToolbarConfig -> ToolbarConfig -> Bool
/= :: ToolbarConfig -> ToolbarConfig -> Bool
Eq)
-----------------------------------------------------------------------------
defaultToolbarConfig :: ToolbarConfig
defaultToolbarConfig :: ToolbarConfig
defaultToolbarConfig = ToolbarConfig
  { tbPosition :: Position
tbPosition = Position
PositionTop
  , tbOffset :: Double
tbOffset = Double
10
  , tbAlign :: Align
tbAlign = Align
AlignCenter
  }
-----------------------------------------------------------------------------
-- | A toolbar floating next to a node, in container coordinates (it
-- does not scale with the zoom). Include it via 'fvcChildren':
--
-- @
-- fvcChildren = \\scene ->
--   [ v
--   | n <- sceneNodes scene, nodeSelected n
--   , v <- nodeToolbarView defaultToolbarConfig scene (nodeId n) [ … ]
--   ]
-- @
nodeToolbarView
  :: ToolbarConfig
  -> FlowScene n e
  -> NodeId
  -> [View ctx model action]
  -- ^ toolbar content
  -> [View ctx model action]
nodeToolbarView :: forall n e ctx model action.
ToolbarConfig
-> FlowScene n e
-> MisoString
-> [View ctx model action]
-> [View ctx model action]
nodeToolbarView ToolbarConfig {Double
Align
Position
tbPosition :: ToolbarConfig -> Position
tbOffset :: ToolbarConfig -> Double
tbAlign :: ToolbarConfig -> Align
tbPosition :: Position
tbOffset :: Double
tbAlign :: Align
..} FlowScene {[Edge e]
[Node n]
Maybe Rect
NodeLookup n
ConnectionState n
Dimensions
Viewport
StoreOptions
sceneNodes :: forall n e. FlowScene n e -> [Node n]
sceneNodeLookup :: forall n e. FlowScene n e -> NodeLookup n
sceneEdges :: forall n e. FlowScene n e -> [Edge e]
sceneViewport :: forall n e. FlowScene n e -> Viewport
sceneConnection :: forall n e. FlowScene n e -> ConnectionState n
sceneDimensions :: forall n e. FlowScene n e -> Dimensions
sceneSelectionRect :: forall n e. FlowScene n e -> Maybe Rect
sceneOptions :: forall n e. FlowScene n e -> StoreOptions
sceneNodes :: [Node n]
sceneNodeLookup :: NodeLookup n
sceneEdges :: [Edge e]
sceneViewport :: Viewport
sceneConnection :: ConnectionState n
sceneDimensions :: Dimensions
sceneSelectionRect :: Maybe Rect
sceneOptions :: StoreOptions
..} MisoString
nid [View ctx model action]
content =
  case MisoString -> NodeLookup n -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MisoString
nid NodeLookup n
sceneNodeLookup of
    Just InternalNode n
internal
      | Just Dimensions
_ <- Measured -> Maybe Dimensions
measuredToDimensions (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
internal) ->
          [ [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
              [ MisoString -> Attribute model action
forall key model action. ToKey key => key -> Attribute model action
key_ (MisoString
"toolbar-" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
nid)
              , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__node-toolbar"
              , [Style] -> Attribute model action
forall model action. [Style] -> Attribute model action
style_
                  [ ( MisoString
"transform"
                    , Rect -> Viewport -> Position -> Double -> Align -> MisoString
getNodeToolbarTransform
                        (InternalNode n -> Rect
forall n. InternalNode n -> Rect
internalNodeToRect InternalNode n
internal)
                        Viewport
sceneViewport Position
tbPosition Double
tbOffset Align
tbAlign
                    )
                  , (MisoString
"z-index", MisoString
"6")
                  ]
              ]
              [View ctx model action]
content
          ]
    Maybe (InternalNode n)
_ -> []
-- | A toolbar floating at an edge's label position. Rendered in flow
-- coordinates but inverse-scaled so it keeps a constant size — include
-- it via 'fvcViewportChildren' (it must live inside the viewport):
--
-- @
-- fvcViewportChildren = \scene ->
--   [ v
--   | e <- sceneEdges scene, edgeSelected e
--   , v <- edgeToolbarView cfg scene (edgeId e) [ … ]
--   ]
-- @
edgeToolbarView
  :: FlowViewConfig ctx n e model action
  -> FlowScene n e
  -> EdgeId
  -> [View ctx model action]
  -- ^ toolbar content
  -> [View ctx model action]
edgeToolbarView :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e
-> MisoString
-> [View ctx model action]
-> [View ctx model action]
edgeToolbarView FlowViewConfig {Bool
[Attribute model action]
MisoString
ConnectionLineType
ConnectionMode
FlowHooks action
FlowScene n e -> [View ctx model action]
NodeContentRenderer ctx n e model action
fvcFlowId :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> MisoString
fvcDark :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcConnectionMode :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionMode
fvcConnectionLineType :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionLineType
fvcShowBackground :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcNodeContent :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> NodeContentRenderer ctx n e model action
fvcAttrs :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> [Attribute model action]
fvcChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcViewportChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcHooks :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> FlowHooks action
fvcFlowId :: MisoString
fvcDark :: Bool
fvcConnectionMode :: ConnectionMode
fvcConnectionLineType :: ConnectionLineType
fvcShowBackground :: Bool
fvcNodeContent :: NodeContentRenderer ctx n e model action
fvcAttrs :: [Attribute model action]
fvcChildren :: FlowScene n e -> [View ctx model action]
fvcViewportChildren :: FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: Bool
fvcHooks :: FlowHooks action
..} FlowScene {[Edge e]
[Node n]
Maybe Rect
NodeLookup n
ConnectionState n
Dimensions
Viewport
StoreOptions
sceneNodes :: forall n e. FlowScene n e -> [Node n]
sceneNodeLookup :: forall n e. FlowScene n e -> NodeLookup n
sceneEdges :: forall n e. FlowScene n e -> [Edge e]
sceneViewport :: forall n e. FlowScene n e -> Viewport
sceneConnection :: forall n e. FlowScene n e -> ConnectionState n
sceneDimensions :: forall n e. FlowScene n e -> Dimensions
sceneSelectionRect :: forall n e. FlowScene n e -> Maybe Rect
sceneOptions :: forall n e. FlowScene n e -> StoreOptions
sceneNodes :: [Node n]
sceneNodeLookup :: NodeLookup n
sceneEdges :: [Edge e]
sceneViewport :: Viewport
sceneConnection :: ConnectionState n
sceneDimensions :: Dimensions
sceneSelectionRect :: Maybe Rect
sceneOptions :: StoreOptions
..} MisoString
eid [View ctx model action]
content =
  case [ Edge e
e | Edge e
e <- [Edge e]
sceneEdges, 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
e : [Edge e]
_)
      | Just EdgePath
ep <- ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePath
forall n e.
ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePath
edgePathFor ConnectionMode
fvcConnectionMode NodeLookup n
sceneNodeLookup Edge e
e ->
          [ [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
              [ MisoString -> Attribute model action
forall key model action. ToKey key => key -> Attribute model action
key_ (MisoString
"edge-toolbar-" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
eid)
              , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__edge-toolbar"
              , [Style] -> Attribute model action
forall model action. [Style] -> Attribute model action
style_
                  [ ( MisoString
"transform"
                    , Double -> Double -> Double -> AlignX -> AlignY -> MisoString
getEdgeToolbarTransform
                        (EdgePath -> Double
edgePathLabelX EdgePath
ep) (EdgePath -> Double
edgePathLabelY EdgePath
ep)
                        (Viewport -> Double
viewportZoom Viewport
sceneViewport)
                        AlignX
AlignXCenter AlignY
AlignYCenter
                    )
                  ]
              ]
              [View ctx model action]
content
          ]
    [Edge e]
_ -> []
-----------------------------------------------------------------------------
-- | Resolve an edge's endpoints against the lookup; 'Nothing' until
-- both endpoint nodes are measured.
edgePositionFor :: ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePosition
edgePositionFor :: forall n e.
ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePosition
edgePositionFor ConnectionMode
connectionMode NodeLookup n
nodeLookup Edge e
e = do
  sourceNode <- MisoString -> NodeLookup n -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Edge e -> MisoString
forall e. Edge e -> MisoString
edgeSource Edge e
e) NodeLookup n
nodeLookup
  targetNode <- M.lookup (edgeTarget e) nodeLookup
  getEdgePosition
    sourceNode (edgeSourceHandle e)
    targetNode (edgeTargetHandle e)
    connectionMode
-----------------------------------------------------------------------------
-- | Resolve an edge's endpoints against the lookup and produce its
-- path, honoring the edge's @type@ (@default@ \/ bezier, @straight@,
-- @step@, @smoothstep@, @simplebezier@). 'Nothing' until both endpoint
-- nodes are measured.
edgePathFor :: ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePath
edgePathFor :: forall n e.
ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePath
edgePathFor ConnectionMode
connectionMode NodeLookup n
nodeLookup Edge e
e =
  MisoString -> EdgePosition -> EdgePath
pathByType (MisoString -> Maybe MisoString -> MisoString
forall a. a -> Maybe a -> a
fromMaybe MisoString
"default" (Edge e -> Maybe MisoString
forall e. Edge e -> Maybe MisoString
edgeType Edge e
e))
    (EdgePosition -> EdgePath) -> Maybe EdgePosition -> Maybe EdgePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePosition
forall n e.
ConnectionMode -> NodeLookup n -> Edge e -> Maybe EdgePosition
edgePositionFor ConnectionMode
connectionMode NodeLookup n
nodeLookup Edge e
e
-----------------------------------------------------------------------------
pathByType :: MisoString -> EdgePosition -> EdgePath
pathByType :: MisoString -> EdgePosition -> EdgePath
pathByType MisoString
ty EdgePosition {Double
Position
epSourceX :: EdgePosition -> Double
epSourceY :: EdgePosition -> Double
epSourcePosition :: EdgePosition -> Position
epTargetX :: EdgePosition -> Double
epTargetY :: EdgePosition -> Double
epTargetPosition :: EdgePosition -> Position
epSourceX :: Double
epSourceY :: Double
epTargetX :: Double
epTargetY :: Double
epSourcePosition :: Position
epTargetPosition :: Position
..} = case MisoString
ty of
  MisoString
"straight" -> Double -> Double -> Double -> Double -> EdgePath
getStraightPath Double
epSourceX Double
epSourceY Double
epTargetX Double
epTargetY
  MisoString
"step" -> Double -> EdgePath
smoothStep Double
0
  MisoString
"smoothstep" -> Double -> EdgePath
smoothStep Double
5
  MisoString
"simplebezier" ->
    Double
-> Double -> Position -> Double -> Double -> Position -> EdgePath
getSimpleBezierPath
      Double
epSourceX Double
epSourceY Position
epSourcePosition
      Double
epTargetX Double
epTargetY Position
epTargetPosition
  MisoString
_ ->
    GetBezierPathParams -> EdgePath
getBezierPath
      (Double -> Double -> Double -> Double -> GetBezierPathParams
bezierPathParams Double
epSourceX Double
epSourceY Double
epTargetX Double
epTargetY)
        { bezierSourcePosition = epSourcePosition
        , bezierTargetPosition = epTargetPosition
        }
  where
    smoothStep :: Double -> EdgePath
smoothStep Double
radius =
      GetSmoothStepPathParams -> EdgePath
getSmoothStepPath
        (Double -> Double -> Double -> Double -> GetSmoothStepPathParams
smoothStepPathParams Double
epSourceX Double
epSourceY Double
epTargetX Double
epTargetY)
          { smoothSourcePosition = epSourcePosition
          , smoothTargetPosition = epTargetPosition
          , smoothBorderRadius = radius
          }
-----------------------------------------------------------------------------
markerDefs :: MisoString -> [Edge e] -> View ctx model action
markerDefs :: forall e ctx model action.
MisoString -> [Edge e] -> View ctx model action
markerDefs MisoString
flowId [Edge e]
edges =
  [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
S.defs_ [] ((MarkerProps -> View ctx model action)
-> [MarkerProps] -> [View ctx model action]
forall a b. (a -> b) -> [a] -> [b]
map MarkerProps -> View ctx model action
forall {context} {model} {action}.
MarkerProps -> View context model action
markerDef ([Edge e]
-> Maybe MisoString
-> Maybe MisoString
-> Maybe EdgeMarkerType
-> Maybe EdgeMarkerType
-> [MarkerProps]
forall e.
[Edge e]
-> Maybe MisoString
-> Maybe MisoString
-> Maybe EdgeMarkerType
-> Maybe EdgeMarkerType
-> [MarkerProps]
createMarkerIds [Edge e]
edges (MisoString -> Maybe MisoString
forall a. a -> Maybe a
Just MisoString
flowId) Maybe MisoString
forall a. Maybe a
Nothing Maybe EdgeMarkerType
forall a. Maybe a
Nothing Maybe EdgeMarkerType
forall a. Maybe a
Nothing))
  where
    markerDef :: MarkerProps -> View context model action
markerDef (MarkerProps MisoString
mid EdgeMarker {Maybe Double
Maybe MisoString
MarkerType
markerType :: MarkerType
markerColor :: Maybe MisoString
markerWidth :: Maybe Double
markerHeight :: Maybe Double
markerUnits :: Maybe MisoString
markerOrient :: Maybe MisoString
markerStrokeWidth :: Maybe Double
markerColor :: EdgeMarker -> Maybe MisoString
markerHeight :: EdgeMarker -> Maybe Double
markerOrient :: EdgeMarker -> Maybe MisoString
markerStrokeWidth :: EdgeMarker -> Maybe Double
markerType :: EdgeMarker -> MarkerType
markerUnits :: EdgeMarker -> Maybe MisoString
markerWidth :: EdgeMarker -> Maybe Double
..}) =
      [Attribute model action]
-> [View context model action] -> View context model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
S.marker_
        [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.id_ MisoString
mid
        , MisoString -> Attribute model action
forall key model action. ToKey key => key -> Attribute model action
key_ MisoString
mid
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__arrowhead"
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.markerWidth_ (Double -> MisoString
jsShow (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
12.5 Maybe Double
markerWidth))
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.markerHeight_ (Double -> MisoString
jsShow (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
12.5 Maybe Double
markerHeight))
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.viewBox_ MisoString
"-10 -10 20 20"
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.markerUnits_ (MisoString -> Maybe MisoString -> MisoString
forall a. a -> Maybe a -> a
fromMaybe MisoString
"strokeWidth" Maybe MisoString
markerUnits)
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.orient_ (MisoString -> Maybe MisoString -> MisoString
forall a. a -> Maybe a -> a
fromMaybe MisoString
"auto-start-reverse" Maybe MisoString
markerOrient)
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.refX_ MisoString
"0"
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.refY_ MisoString
"0"
        ]
        [ MarkerType
-> Maybe MisoString -> Maybe Double -> View context model action
forall {context} {model} {action}.
MarkerType
-> Maybe MisoString -> Maybe Double -> View context model action
arrowSymbol MarkerType
markerType Maybe MisoString
markerColor Maybe Double
markerStrokeWidth ]
    arrowSymbol :: MarkerType
-> Maybe MisoString -> Maybe Double -> View context model action
arrowSymbol MarkerType
mt Maybe MisoString
color Maybe Double
strokeWidth =
      [Attribute model action] -> View context model action
forall model action context.
[Attribute model action] -> View context model action
S.polyline_
        ( [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.stroke_ (MisoString -> Maybe MisoString -> MisoString
forall a. a -> Maybe a -> a
fromMaybe MisoString
"var(--mf-edge)" Maybe MisoString
color)
          , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.strokeLinecap_ MisoString
"round"
          , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.strokeLinejoin_ MisoString
"round"
          , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.strokeWidth_ (Double -> MisoString
jsShow (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 Maybe Double
strokeWidth))
          ]
       [Attribute model action]
-> [Attribute model action] -> [Attribute model action]
forall a. Semigroup a => a -> a -> a
<> case MarkerType
mt of
            MarkerType
MarkerArrow ->
              [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.points_ MisoString
"-5,-4 0,0 -5,4", MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.fill_ MisoString
"none" ]
            MarkerType
MarkerArrowClosed ->
              [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.points_ MisoString
"-5,-4 0,0 -5,4 -5,-4"
              , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.fill_ (MisoString -> Maybe MisoString -> MisoString
forall a. a -> Maybe a -> a
fromMaybe MisoString
"var(--mf-edge)" Maybe MisoString
color)
              ]
        )
-----------------------------------------------------------------------------
-- | Shift\/meta\/ctrl pressed during the event?
multiModifierDecoder :: Decoder Bool
multiModifierDecoder :: Decoder Bool
multiModifierDecoder = Decoder
  { decodeAt :: DecodeTarget
decodeAt = [MisoString] -> DecodeTarget
DecodeTarget [MisoString]
forall a. Monoid a => a
mempty
  , decoder :: Value -> Parser Bool
decoder = MisoString -> (Object -> Parser Bool) -> Value -> Parser Bool
forall a. MisoString -> (Object -> Parser a) -> Value -> Parser a
withObject MisoString
"event" ((Object -> Parser Bool) -> Value -> Parser Bool)
-> (Object -> Parser Bool) -> Value -> Parser Bool
forall a b. (a -> b) -> a -> b
$ \Object
o ->
      (\Bool
sk Bool
mk Bool
ck -> Bool
sk Bool -> Bool -> Bool
|| Bool
mk Bool -> Bool -> Bool
|| Bool
ck)
        (Bool -> Bool -> Bool -> Bool)
-> Parser Bool -> Parser (Bool -> Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> MisoString -> Parser Bool
forall a. FromJSON a => Object -> MisoString -> Parser a
.: MisoString
"shiftKey"
        Parser (Bool -> Bool -> Bool)
-> Parser Bool -> Parser (Bool -> Bool)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> MisoString -> Parser Bool
forall a. FromJSON a => Object -> MisoString -> Parser a
.: MisoString
"metaKey"
        Parser (Bool -> Bool) -> Parser Bool -> Parser Bool
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> MisoString -> Parser Bool
forall a. FromJSON a => Object -> MisoString -> Parser a
.: MisoString
"ctrlKey"
  }
-----------------------------------------------------------------------------
selectionRectView :: Maybe Rect -> [View ctx model action]
selectionRectView :: forall ctx model action. Maybe Rect -> [View ctx model action]
selectionRectView Maybe Rect
Nothing = []
selectionRectView (Just (Rect Double
x Double
y Double
w Double
h)) =
  [ [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
      [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__selection"
      , [Style] -> Attribute model action
forall model action. [Style] -> Attribute model action
style_
          [ (MisoString
"left", Double -> MisoString
jsShow Double
x MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"px")
          , (MisoString
"top", Double -> MisoString
jsShow Double
y MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"px")
          , (MisoString
"width", Double -> MisoString
jsShow Double
w MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"px")
          , (MisoString
"height", Double -> MisoString
jsShow Double
h MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"px")
          ]
      ]
      []
  ]
-----------------------------------------------------------------------------
-- * Connection line
-----------------------------------------------------------------------------
connectionLineView
  :: FlowViewConfig ctx n e model action
  -> ConnectionState n
  -> [View ctx model action]
connectionLineView :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> ConnectionState n -> [View ctx model action]
connectionLineView FlowViewConfig ctx n e model action
_ ConnectionState n
NoConnection = []
connectionLineView FlowViewConfig {Bool
[Attribute model action]
MisoString
ConnectionLineType
ConnectionMode
FlowHooks action
FlowScene n e -> [View ctx model action]
NodeContentRenderer ctx n e model action
fvcFlowId :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> MisoString
fvcDark :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcConnectionMode :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionMode
fvcConnectionLineType :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionLineType
fvcShowBackground :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcNodeContent :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> NodeContentRenderer ctx n e model action
fvcAttrs :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> [Attribute model action]
fvcChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcViewportChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcHooks :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> FlowHooks action
fvcFlowId :: MisoString
fvcDark :: Bool
fvcConnectionMode :: ConnectionMode
fvcConnectionLineType :: ConnectionLineType
fvcShowBackground :: Bool
fvcNodeContent :: NodeContentRenderer ctx n e model action
fvcAttrs :: [Attribute model action]
fvcChildren :: FlowScene n e -> [View ctx model action]
fvcViewportChildren :: FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: Bool
fvcHooks :: FlowHooks action
..} (InProgress ConnectionInProgress n
cip) =
  [ [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
S.svg_
      [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__connectionline" ]
      [ [Attribute model action] -> View ctx model action
forall model action context.
[Attribute model action] -> View context model action
S.path_
          [ [MisoString] -> Attribute model action
forall model action. [MisoString] -> Attribute model action
P.classes_ ([MisoString] -> Attribute model action)
-> [MisoString] -> Attribute model action
forall a b. (a -> b) -> a -> b
$ [Maybe MisoString] -> [MisoString]
forall a. [Maybe a] -> [a]
catMaybes
              [ MisoString -> Maybe MisoString
forall a. a -> Maybe a
Just MisoString
"miso-flow__connection-path"
              , (\Bool
v -> if Bool
v then MisoString
"valid" else MisoString
"invalid") (Bool -> MisoString) -> Maybe Bool -> Maybe MisoString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConnectionInProgress n -> Maybe Bool
forall n. ConnectionInProgress n -> Maybe Bool
cipIsValid ConnectionInProgress n
cip
              ]
          , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.d_ (EdgePath -> MisoString
edgePath (ConnectionLineType -> ConnectionInProgress n -> EdgePath
forall n. ConnectionLineType -> ConnectionInProgress n -> EdgePath
connectionPathFor ConnectionLineType
fvcConnectionLineType ConnectionInProgress n
cip))
          ]
      ]
  ]
-----------------------------------------------------------------------------
-- | Path of the in-progress connection line, from the source handle to
-- the pointer.
connectionPathFor :: ConnectionLineType -> ConnectionInProgress n -> EdgePath
connectionPathFor :: forall n. ConnectionLineType -> ConnectionInProgress n -> EdgePath
connectionPathFor ConnectionLineType
lineType ConnectionInProgress {Maybe Bool
Maybe Handle
Maybe (InternalNode n)
Handle
InternalNode n
Position
XYPosition
cipIsValid :: forall n. ConnectionInProgress n -> Maybe Bool
cipIsValid :: Maybe Bool
cipFrom :: XYPosition
cipFromHandle :: Handle
cipFromPosition :: Position
cipFromNode :: InternalNode n
cipTo :: XYPosition
cipToHandle :: Maybe Handle
cipToPosition :: Position
cipToNode :: Maybe (InternalNode n)
cipPointer :: XYPosition
cipFrom :: forall n. ConnectionInProgress n -> XYPosition
cipFromHandle :: forall n. ConnectionInProgress n -> Handle
cipFromNode :: forall n. ConnectionInProgress n -> InternalNode n
cipFromPosition :: forall n. ConnectionInProgress n -> Position
cipPointer :: forall n. ConnectionInProgress n -> XYPosition
cipTo :: forall n. ConnectionInProgress n -> XYPosition
cipToHandle :: forall n. ConnectionInProgress n -> Maybe Handle
cipToNode :: forall n. ConnectionInProgress n -> Maybe (InternalNode n)
cipToPosition :: forall n. ConnectionInProgress n -> Position
..} =
  MisoString -> EdgePosition -> EdgePath
pathByType MisoString
ty
    EdgePosition
      { epSourceX :: Double
epSourceX = XYPosition -> Double
xyX XYPosition
cipFrom
      , epSourceY :: Double
epSourceY = XYPosition -> Double
xyY XYPosition
cipFrom
      , epTargetX :: Double
epTargetX = XYPosition -> Double
xyX XYPosition
cipTo
      , epTargetY :: Double
epTargetY = XYPosition -> Double
xyY XYPosition
cipTo
      , epSourcePosition :: Position
epSourcePosition = Position
cipFromPosition
      , epTargetPosition :: Position
epTargetPosition = Position
cipToPosition
      }
  where
    ty :: MisoString
ty = case ConnectionLineType
lineType of
      ConnectionLineType
ConnectionLineBezier -> MisoString
"default"
      ConnectionLineType
ConnectionLineStraight -> MisoString
"straight"
      ConnectionLineType
ConnectionLineStep -> MisoString
"step"
      ConnectionLineType
ConnectionLineSmoothStep -> MisoString
"smoothstep"
      ConnectionLineType
ConnectionLineSimpleBezier -> MisoString
"simplebezier"
-----------------------------------------------------------------------------
-- * Background
-----------------------------------------------------------------------------
backgroundView :: MisoString -> Viewport -> View ctx model action
backgroundView :: forall ctx model action.
MisoString -> Viewport -> View ctx model action
backgroundView MisoString
flowId Viewport {Double
viewportX :: Viewport -> Double
viewportY :: Viewport -> Double
viewportZoom :: Viewport -> Double
viewportX :: Double
viewportY :: Double
viewportZoom :: Double
..} =
  [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
S.svg_
    [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__background" ]
    [ [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
S.pattern_
        [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.id_ MisoString
patternId
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.x_ (Double -> MisoString
jsShow (Double
viewportX Double -> Double -> Double
forall {a}. RealFrac a => a -> a -> a
`fmod` Double
gap))
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.y_ (Double -> MisoString
jsShow (Double
viewportY Double -> Double -> Double
forall {a}. RealFrac a => a -> a -> a
`fmod` Double
gap))
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.width_ (Double -> MisoString
jsShow Double
gap)
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.height_ (Double -> MisoString
jsShow Double
gap)
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.patternUnits_ MisoString
"userSpaceOnUse"
        ]
        [ [Attribute model action] -> View ctx model action
forall model action context.
[Attribute model action] -> View context model action
S.circle_
            [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.cx_ (Double -> MisoString
jsShow Double
radius)
            , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.cy_ (Double -> MisoString
jsShow Double
radius)
            , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.r_ (Double -> MisoString
jsShow Double
radius)
            , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.fill_ MisoString
"var(--mf-dots)"
            ]
        ]
    , [Attribute model action] -> View ctx model action
forall model action context.
[Attribute model action] -> View context model action
S.rect_
        [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.x_ MisoString
"0", MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.y_ MisoString
"0"
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.width_ MisoString
"100%", MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.height_ MisoString
"100%"
        , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.fill_ (MisoString
"url(#" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
patternId MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
")")
        ]
    ]
  where
    patternId :: MisoString
patternId = MisoString
"miso-flow__bg-" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
flowId
    gap :: Double
gap = Double
20 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
viewportZoom
    radius :: Double
radius = Double
viewportZoom
    fmod :: a -> a -> a
fmod a
a a
b = a
a a -> a -> a
forall a. Num a => a -> a -> a
- a
b a -> a -> a
forall a. Num a => a -> a -> a
* Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Integer
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (a
a a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
b) :: Integer)
-----------------------------------------------------------------------------
-- * Panels & controls
-----------------------------------------------------------------------------
-- | A positioned overlay panel (see @.miso-flow__panel@ in
-- "Miso.Flow.Style").
panelView
  :: PanelPosition
  -> [View ctx model action]
  -> View ctx model action
panelView :: forall ctx model action.
PanelPosition -> [View ctx model action] -> View ctx model action
panelView PanelPosition
position =
  [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_ [ [MisoString] -> Attribute model action
forall model action. [MisoString] -> Attribute model action
P.classes_ (MisoString
"miso-flow__panel" MisoString -> [MisoString] -> [MisoString]
forall a. a -> [a] -> [a]
: PanelPosition -> [MisoString]
positionClasses PanelPosition
position) ]
  where
    positionClasses :: PanelPosition -> [MisoString]
positionClasses = \case
      PanelPosition
TopLeft      -> [ MisoString
"top", MisoString
"left" ]
      PanelPosition
TopCenter    -> [ MisoString
"top", MisoString
"center-h" ]
      PanelPosition
TopRight     -> [ MisoString
"top", MisoString
"right" ]
      PanelPosition
BottomLeft   -> [ MisoString
"bottom", MisoString
"left" ]
      PanelPosition
BottomCenter -> [ MisoString
"bottom", MisoString
"center-h" ]
      PanelPosition
BottomRight  -> [ MisoString
"bottom", MisoString
"right" ]
      PanelPosition
CenterLeft   -> [ MisoString
"left", MisoString
"center-v" ]
      PanelPosition
CenterRight  -> [ MisoString
"right", MisoString
"center-v" ]
-----------------------------------------------------------------------------
-- | A column of control buttons, one per @(label, action)@.
controlsView
  :: PanelPosition
  -> [(MisoString, action)]
  -> View ctx model action
controlsView :: forall action ctx model.
PanelPosition -> [(MisoString, action)] -> View ctx model action
controlsView PanelPosition
position [(MisoString, action)]
buttons =
  PanelPosition -> [View ctx model action] -> View ctx model action
forall ctx model action.
PanelPosition -> [View ctx model action] -> View ctx model action
panelView PanelPosition
position
    [ [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
        [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__controls" ]
        [ [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.button_
            [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__controls-button"
            , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.type_ MisoString
"button"
            , action -> Attribute model action
forall action model. action -> Attribute model action
H.onClick action
action
            ]
            [ MisoString -> View ctx model action
forall context model action.
MisoString -> View context model action
text MisoString
label ]
        | (MisoString
label, action
action) <- [(MisoString, action)]
buttons
        ]
    ]
-----------------------------------------------------------------------------
-- * Minimap
-----------------------------------------------------------------------------
data MinimapConfig = MinimapConfig
  { MinimapConfig -> Double
mmWidth :: !Double
  , MinimapConfig -> Double
mmHeight :: !Double
  , MinimapConfig -> PanelPosition
mmPosition :: !PanelPosition
  , MinimapConfig -> Bool
mmPannable :: !Bool
  , MinimapConfig -> Bool
mmZoomable :: !Bool
  , MinimapConfig -> Bool
mmInversePan :: !Bool
  , MinimapConfig -> Double
mmZoomStep :: !Double
  , MinimapConfig -> Double
mmNodeBorderRadius :: !Double
  , MinimapConfig -> Double
mmOffsetScale :: !Double
  } deriving (Int -> MinimapConfig -> ShowS
[MinimapConfig] -> ShowS
MinimapConfig -> String
(Int -> MinimapConfig -> ShowS)
-> (MinimapConfig -> String)
-> ([MinimapConfig] -> ShowS)
-> Show MinimapConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MinimapConfig -> ShowS
showsPrec :: Int -> MinimapConfig -> ShowS
$cshow :: MinimapConfig -> String
show :: MinimapConfig -> String
$cshowList :: [MinimapConfig] -> ShowS
showList :: [MinimapConfig] -> ShowS
Show, MinimapConfig -> MinimapConfig -> Bool
(MinimapConfig -> MinimapConfig -> Bool)
-> (MinimapConfig -> MinimapConfig -> Bool) -> Eq MinimapConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MinimapConfig -> MinimapConfig -> Bool
== :: MinimapConfig -> MinimapConfig -> Bool
$c/= :: MinimapConfig -> MinimapConfig -> Bool
/= :: MinimapConfig -> MinimapConfig -> Bool
Eq)
-----------------------------------------------------------------------------
-- | xyflow's minimap defaults (pannable\/zoomable on, bottom right).
defaultMinimapConfig :: MinimapConfig
defaultMinimapConfig :: MinimapConfig
defaultMinimapConfig = MinimapConfig
  { mmWidth :: Double
mmWidth = Double
200
  , mmHeight :: Double
mmHeight = Double
150
  , mmPosition :: PanelPosition
mmPosition = PanelPosition
BottomRight
  , mmPannable :: Bool
mmPannable = Bool
True
  , mmZoomable :: Bool
mmZoomable = Bool
True
  , mmInversePan :: Bool
mmInversePan = Bool
False
  , mmZoomStep :: Double
mmZoomStep = Double
1
  , mmNodeBorderRadius :: Double
mmNodeBorderRadius = Double
5
  , mmOffsetScale :: Double
mmOffsetScale = Double
5
  }
-----------------------------------------------------------------------------
-- | viewBB, boundingRect and viewScale; the math of the framework
-- packages' MiniMap component.
minimapGeometry
  :: MinimapConfig
  -> Dimensions          -- ^ container size
  -> Viewport
  -> NodeLookup n
  -> (Rect, Rect, Double)
minimapGeometry :: forall n.
MinimapConfig
-> Dimensions -> Viewport -> NodeLookup n -> (Rect, Rect, Double)
minimapGeometry MinimapConfig {Bool
Double
PanelPosition
mmWidth :: MinimapConfig -> Double
mmHeight :: MinimapConfig -> Double
mmPosition :: MinimapConfig -> PanelPosition
mmPannable :: MinimapConfig -> Bool
mmZoomable :: MinimapConfig -> Bool
mmInversePan :: MinimapConfig -> Bool
mmZoomStep :: MinimapConfig -> Double
mmNodeBorderRadius :: MinimapConfig -> Double
mmOffsetScale :: MinimapConfig -> Double
mmWidth :: Double
mmHeight :: Double
mmPosition :: PanelPosition
mmPannable :: Bool
mmZoomable :: Bool
mmInversePan :: Bool
mmZoomStep :: Double
mmNodeBorderRadius :: Double
mmOffsetScale :: Double
..} (Dimensions Double
w Double
h) (Viewport Double
tx Double
ty Double
tz) NodeLookup n
nodeLookup =
  (Rect
viewBB, Rect
boundingRect, Double
viewScale)
  where
    viewBB :: Rect
viewBB = Double -> Double -> Double -> Double -> Rect
Rect (Double -> Double
forall a. Num a => a -> a
negate Double
tx Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tz) (Double -> Double
forall a. Num a => a -> a
negate Double
ty Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tz) (Double
w Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tz) (Double
h Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
tz)
    visible :: InternalNode n -> Bool
visible = Bool -> Bool
not (Bool -> Bool)
-> (InternalNode n -> Bool) -> InternalNode n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node n -> Bool
forall n. Node n -> Bool
nodeHidden (Node n -> Bool)
-> (InternalNode n -> Node n) -> InternalNode n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUserNode
    boundingRect :: Rect
boundingRect
      | (InternalNode n -> Bool) -> [InternalNode n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any InternalNode n -> Bool
forall {n}. InternalNode n -> Bool
visible (NodeLookup n -> [InternalNode n]
forall k a. Map k a -> [a]
M.elems NodeLookup n
nodeLookup) =
          Rect -> Rect -> Rect
getBoundsOfRects ((InternalNode n -> Bool) -> NodeLookup n -> Rect
forall n. (InternalNode n -> Bool) -> NodeLookup n -> Rect
getInternalNodesBounds InternalNode n -> Bool
forall {n}. InternalNode n -> Bool
visible NodeLookup n
nodeLookup) Rect
viewBB
      | Bool
otherwise = Rect
viewBB
    viewScale :: Double
viewScale =
      Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Rect -> Double
rectWidth Rect
boundingRect Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
mmWidth) (Rect -> Double
rectHeight Rect
boundingRect Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
mmHeight)
-----------------------------------------------------------------------------
-- | The scale the XYMinimap gesture code needs (the component layer
-- forwards it over the bridge whenever the scene changes).
minimapViewScaleFor
  :: MinimapConfig -> Dimensions -> Viewport -> NodeLookup n -> Double
minimapViewScaleFor :: forall n.
MinimapConfig -> Dimensions -> Viewport -> NodeLookup n -> Double
minimapViewScaleFor MinimapConfig
mm Dimensions
dims Viewport
viewport NodeLookup n
nodeLookup =
  let (Rect
_, Rect
_, Double
viewScale) = MinimapConfig
-> Dimensions -> Viewport -> NodeLookup n -> (Rect, Rect, Double)
forall n.
MinimapConfig
-> Dimensions -> Viewport -> NodeLookup n -> (Rect, Rect, Double)
minimapGeometry MinimapConfig
mm Dimensions
dims Viewport
viewport NodeLookup n
nodeLookup in Double
viewScale
-----------------------------------------------------------------------------
-- | A pannable\/zoomable overview map. Include it in 'fvcChildren'.
minimapView
  :: MinimapConfig
  -> FlowViewConfig ctx n e model action
  -> FlowScene n e
  -> View ctx model action
minimapView :: forall ctx n e model action.
MinimapConfig
-> FlowViewConfig ctx n e model action
-> FlowScene n e
-> View ctx model action
minimapView mm :: MinimapConfig
mm@MinimapConfig {Bool
Double
PanelPosition
mmWidth :: MinimapConfig -> Double
mmHeight :: MinimapConfig -> Double
mmPosition :: MinimapConfig -> PanelPosition
mmPannable :: MinimapConfig -> Bool
mmZoomable :: MinimapConfig -> Bool
mmInversePan :: MinimapConfig -> Bool
mmZoomStep :: MinimapConfig -> Double
mmNodeBorderRadius :: MinimapConfig -> Double
mmOffsetScale :: MinimapConfig -> Double
mmWidth :: Double
mmHeight :: Double
mmPosition :: PanelPosition
mmPannable :: Bool
mmZoomable :: Bool
mmInversePan :: Bool
mmZoomStep :: Double
mmNodeBorderRadius :: Double
mmOffsetScale :: Double
..} FlowViewConfig {Bool
[Attribute model action]
MisoString
ConnectionLineType
ConnectionMode
FlowHooks action
FlowScene n e -> [View ctx model action]
NodeContentRenderer ctx n e model action
fvcFlowId :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> MisoString
fvcDark :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcConnectionMode :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionMode
fvcConnectionLineType :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionLineType
fvcShowBackground :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcNodeContent :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> NodeContentRenderer ctx n e model action
fvcAttrs :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> [Attribute model action]
fvcChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcViewportChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcHooks :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> FlowHooks action
fvcFlowId :: MisoString
fvcDark :: Bool
fvcConnectionMode :: ConnectionMode
fvcConnectionLineType :: ConnectionLineType
fvcShowBackground :: Bool
fvcNodeContent :: NodeContentRenderer ctx n e model action
fvcAttrs :: [Attribute model action]
fvcChildren :: FlowScene n e -> [View ctx model action]
fvcViewportChildren :: FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: Bool
fvcHooks :: FlowHooks action
..} FlowScene {[Edge e]
[Node n]
Maybe Rect
NodeLookup n
ConnectionState n
Dimensions
Viewport
StoreOptions
sceneNodes :: forall n e. FlowScene n e -> [Node n]
sceneNodeLookup :: forall n e. FlowScene n e -> NodeLookup n
sceneEdges :: forall n e. FlowScene n e -> [Edge e]
sceneViewport :: forall n e. FlowScene n e -> Viewport
sceneConnection :: forall n e. FlowScene n e -> ConnectionState n
sceneDimensions :: forall n e. FlowScene n e -> Dimensions
sceneSelectionRect :: forall n e. FlowScene n e -> Maybe Rect
sceneOptions :: forall n e. FlowScene n e -> StoreOptions
sceneNodes :: [Node n]
sceneNodeLookup :: NodeLookup n
sceneEdges :: [Edge e]
sceneViewport :: Viewport
sceneConnection :: ConnectionState n
sceneDimensions :: Dimensions
sceneSelectionRect :: Maybe Rect
sceneOptions :: StoreOptions
..} =
  PanelPosition -> [View ctx model action] -> View ctx model action
forall ctx model action.
PanelPosition -> [View ctx model action] -> View ctx model action
panelView PanelPosition
mmPosition
    [ [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
        [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__minimap" ]
        [ [Attribute model action]
-> [View ctx model action] -> View ctx model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
S.svg_
            [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.width_ (Double -> MisoString
jsShow Double
mmWidth)
            , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.height_ (Double -> MisoString
jsShow Double
mmHeight)
            , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.viewBox_ (Double -> MisoString
jsShow Double
x MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
" " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Double -> MisoString
jsShow Double
y MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
" " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Double -> MisoString
jsShow Double
width MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
" " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Double -> MisoString
jsShow Double
height)
            , (DOMRef -> action) -> Attribute model action
forall action model. (DOMRef -> action) -> Attribute model action
onCreatedWith (FlowHooks action -> MinimapConfig -> DOMRef -> action
forall action.
FlowHooks action -> MinimapConfig -> DOMRef -> action
hookMinimapCreated FlowHooks action
fvcHooks MinimapConfig
mm)
            ]
            ( [ [Attribute model action] -> View ctx model action
forall model action context.
[Attribute model action] -> View context model action
S.rect_
                  [ MisoString -> Attribute model action
forall key model action. ToKey key => key -> Attribute model action
key_ (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
u)
                  , [MisoString] -> Attribute model action
forall model action. [MisoString] -> Attribute model action
P.classes_ ([MisoString] -> Attribute model action)
-> [MisoString] -> Attribute model action
forall a b. (a -> b) -> a -> b
$ [Maybe MisoString] -> [MisoString]
forall a. [Maybe a] -> [a]
catMaybes
                      [ MisoString -> Maybe MisoString
forall a. a -> Maybe a
Just MisoString
"miso-flow__minimap-node"
                      , Bool -> MisoString -> Maybe MisoString
forall a. Bool -> a -> Maybe a
justWhen (Node n -> Bool
forall n. Node n -> Bool
nodeSelected Node n
u) MisoString
"selected"
                      ]
                  , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.x_ (Double -> MisoString
jsShow (XYPosition -> Double
xyX (InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute InternalNode n
n)))
                  , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.y_ (Double -> MisoString
jsShow (XYPosition -> Double
xyY (InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute InternalNode n
n)))
                  , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.width_ (Double -> MisoString
jsShow Double
nw)
                  , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.height_ (Double -> MisoString
jsShow Double
nh)
                  , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.rx_ (Double -> MisoString
jsShow Double
mmNodeBorderRadius)
                  ]
              | InternalNode n
n <- NodeLookup n -> [InternalNode n]
forall k a. Map k a -> [a]
M.elems NodeLookup n
sceneNodeLookup
              , let u :: Node n
u = InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUserNode InternalNode n
n
              , let Dimensions Double
nw Double
nh = InternalNode n -> Dimensions
forall n. InternalNode n -> Dimensions
getInternalNodeDimensions InternalNode n
n
              , Bool -> Bool
not (Node n -> Bool
forall n. Node n -> Bool
nodeHidden Node n
u)
              , Double
nw Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Double
nh Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
              ]
           [View ctx model action]
-> [View ctx model action] -> [View ctx model action]
forall a. Semigroup a => a -> a -> a
<> [ [Attribute model action] -> View ctx model action
forall model action context.
[Attribute model action] -> View context model action
S.path_
                  [ MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
P.class_ MisoString
"miso-flow__minimap-mask"
                  , MisoString -> Attribute model action
forall model action. MisoString -> Attribute model action
SP.d_ MisoString
maskPath
                  ]
              ]
            )
        ]
    ]
  where
    (Rect
viewBB, Rect
boundingRect, Double
viewScale) =
      MinimapConfig
-> Dimensions -> Viewport -> NodeLookup n -> (Rect, Rect, Double)
forall n.
MinimapConfig
-> Dimensions -> Viewport -> NodeLookup n -> (Rect, Rect, Double)
minimapGeometry MinimapConfig
mm Dimensions
sceneDimensions Viewport
sceneViewport NodeLookup n
sceneNodeLookup
    viewWidth :: Double
viewWidth = Double
viewScale Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
mmWidth
    viewHeight :: Double
viewHeight = Double
viewScale Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
mmHeight
    offset :: Double
offset = Double
mmOffsetScale Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
viewScale
    x :: Double
x = Rect -> Double
rectX Rect
boundingRect Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
viewWidth Double -> Double -> Double
forall a. Num a => a -> a -> a
- Rect -> Double
rectWidth Rect
boundingRect) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
offset
    y :: Double
y = Rect -> Double
rectY Rect
boundingRect Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
viewHeight Double -> Double -> Double
forall a. Num a => a -> a -> a
- Rect -> Double
rectHeight Rect
boundingRect) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
offset
    width :: Double
width = Double
viewWidth Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offset Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2
    height :: Double
height = Double
viewHeight Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offset Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2
    maskPath :: MisoString
maskPath = [MisoString] -> MisoString
forall a. Monoid a => [a] -> a
mconcat
      [ MisoString
"M", Double -> MisoString
jsShow (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
offset), MisoString
",", Double -> MisoString
jsShow (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
offset)
      , MisoString
"h", Double -> MisoString
jsShow (Double
width Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offset Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2)
      , MisoString
"v", Double -> MisoString
jsShow (Double
height Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offset Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2)
      , MisoString
"h", Double -> MisoString
jsShow (Double -> Double
forall a. Num a => a -> a
negate (Double
width Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offset Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2))
      , MisoString
"z M", Double -> MisoString
jsShow (Rect -> Double
rectX Rect
viewBB), MisoString
",", Double -> MisoString
jsShow (Rect -> Double
rectY Rect
viewBB)
      , MisoString
"h", Double -> MisoString
jsShow (Rect -> Double
rectWidth Rect
viewBB)
      , MisoString
"v", Double -> MisoString
jsShow (Rect -> Double
rectHeight Rect
viewBB)
      , MisoString
"h", Double -> MisoString
jsShow (Double -> Double
forall a. Num a => a -> a
negate (Rect -> Double
rectWidth Rect
viewBB))
      , MisoString
"z"
      ]
-----------------------------------------------------------------------------
-- * Node resizer
-----------------------------------------------------------------------------
data ResizerConfig = ResizerConfig
  { ResizerConfig -> Double
rcMinWidth :: !Double
  , ResizerConfig -> Double
rcMinHeight :: !Double
  , ResizerConfig -> Maybe Double
rcMaxWidth :: !(Maybe Double)
  , ResizerConfig -> Maybe Double
rcMaxHeight :: !(Maybe Double)
  , ResizerConfig -> Bool
rcKeepAspectRatio :: !Bool
  } deriving (Int -> ResizerConfig -> ShowS
[ResizerConfig] -> ShowS
ResizerConfig -> String
(Int -> ResizerConfig -> ShowS)
-> (ResizerConfig -> String)
-> ([ResizerConfig] -> ShowS)
-> Show ResizerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ResizerConfig -> ShowS
showsPrec :: Int -> ResizerConfig -> ShowS
$cshow :: ResizerConfig -> String
show :: ResizerConfig -> String
$cshowList :: [ResizerConfig] -> ShowS
showList :: [ResizerConfig] -> ShowS
Show, ResizerConfig -> ResizerConfig -> Bool
(ResizerConfig -> ResizerConfig -> Bool)
-> (ResizerConfig -> ResizerConfig -> Bool) -> Eq ResizerConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ResizerConfig -> ResizerConfig -> Bool
== :: ResizerConfig -> ResizerConfig -> Bool
$c/= :: ResizerConfig -> ResizerConfig -> Bool
/= :: ResizerConfig -> ResizerConfig -> Bool
Eq)
-----------------------------------------------------------------------------
defaultResizerConfig :: ResizerConfig
defaultResizerConfig :: ResizerConfig
defaultResizerConfig = ResizerConfig
  { rcMinWidth :: Double
rcMinWidth = Double
10
  , rcMinHeight :: Double
rcMinHeight = Double
10
  , rcMaxWidth :: Maybe Double
rcMaxWidth = Maybe Double
forall a. Maybe a
Nothing
  , rcMaxHeight :: Maybe Double
rcMaxHeight = Maybe Double
forall a. Maybe a
Nothing
  , rcKeepAspectRatio :: Bool
rcKeepAspectRatio = Bool
False
  }
-----------------------------------------------------------------------------
-- | Resize controls for one node: four edge lines plus four corner
-- handles, wired to XYResizer through the bridge. Render them inside the
-- node's content (typically only while the node is selected):
--
-- @
-- myContent cfg n =
--   nodeResizerView defaultResizerConfig cfg n <> defaultNodeContent label cfg n
-- @
nodeResizerView
  :: ResizerConfig
  -> FlowViewConfig ctx n e model action
  -> Node n
  -> [View ctx model action]
nodeResizerView :: forall ctx n e model action.
ResizerConfig
-> FlowViewConfig ctx n e model action
-> Node n
-> [View ctx model action]
nodeResizerView ResizerConfig {Bool
Double
Maybe Double
rcMinWidth :: ResizerConfig -> Double
rcMinHeight :: ResizerConfig -> Double
rcMaxWidth :: ResizerConfig -> Maybe Double
rcMaxHeight :: ResizerConfig -> Maybe Double
rcKeepAspectRatio :: ResizerConfig -> Bool
rcMinWidth :: Double
rcMinHeight :: Double
rcMaxWidth :: Maybe Double
rcMaxHeight :: Maybe Double
rcKeepAspectRatio :: Bool
..} FlowViewConfig {Bool
[Attribute model action]
MisoString
ConnectionLineType
ConnectionMode
FlowHooks action
FlowScene n e -> [View ctx model action]
NodeContentRenderer ctx n e model action
fvcFlowId :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> MisoString
fvcDark :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcConnectionMode :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionMode
fvcConnectionLineType :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> ConnectionLineType
fvcShowBackground :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcNodeContent :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> NodeContentRenderer ctx n e model action
fvcAttrs :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> [Attribute model action]
fvcChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcViewportChildren :: forall ctx n e model action.
FlowViewConfig ctx n e model action
-> FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> Bool
fvcHooks :: forall ctx n e model action.
FlowViewConfig ctx n e model action -> FlowHooks action
fvcFlowId :: MisoString
fvcDark :: Bool
fvcConnectionMode :: ConnectionMode
fvcConnectionLineType :: ConnectionLineType
fvcShowBackground :: Bool
fvcNodeContent :: NodeContentRenderer ctx n e model action
fvcAttrs :: [Attribute model action]
fvcChildren :: FlowScene n e -> [View ctx model action]
fvcViewportChildren :: FlowScene n e -> [View ctx model action]
fvcEdgesReconnectable :: Bool
fvcHooks :: FlowHooks action
..} Node n
n =
  (ControlPosition -> View ctx model action)
-> [ControlPosition] -> [View ctx model action]
forall a b. (a -> b) -> [a] -> [b]
map (MisoString -> ControlPosition -> View ctx model action
forall {context} {model}.
MisoString -> ControlPosition -> View context model action
control MisoString
"line") ((ControlLinePosition -> ControlPosition)
-> [ControlLinePosition] -> [ControlPosition]
forall a b. (a -> b) -> [a] -> [b]
map ControlLinePosition -> ControlPosition
ControlLine [ ControlLinePosition
ControlLineTop, ControlLinePosition
ControlLineBottom, ControlLinePosition
ControlLineLeft, ControlLinePosition
ControlLineRight ])
    [View ctx model action]
-> [View ctx model action] -> [View ctx model action]
forall a. Semigroup a => a -> a -> a
<> (ControlPosition -> View ctx model action)
-> [ControlPosition] -> [View ctx model action]
forall a b. (a -> b) -> [a] -> [b]
map (MisoString -> ControlPosition -> View ctx model action
forall {context} {model}.
MisoString -> ControlPosition -> View context model action
control MisoString
"handle") [ControlPosition]
xyResizerHandlePositions
  where
    control :: MisoString -> ControlPosition -> View context model action
control MisoString
variant ControlPosition
position =
      [Attribute model action]
-> [View context model action] -> View context model action
forall model action context.
[Attribute model action]
-> [View context model action] -> View context model action
H.div_
        [ [MisoString] -> Attribute model action
forall model action. [MisoString] -> Attribute model action
P.classes_
            [ MisoString
"miso-flow__resize-control"
            , MisoString
"nodrag"
            , MisoString
variant
            , ControlPosition -> MisoString
controlPositionToText ControlPosition
position
            ]
        , MisoString -> MisoString -> Attribute model action
forall model action.
MisoString -> MisoString -> Attribute model action
textProp MisoString
"data-resizer" (ControlPosition -> MisoString
controlPositionToText ControlPosition
position)
        , (DOMRef -> action) -> Attribute model action
forall action model. (DOMRef -> action) -> Attribute model action
onCreatedWith
            (FlowHooks action -> MisoString -> Value -> DOMRef -> action
forall action.
FlowHooks action -> MisoString -> Value -> DOMRef -> action
hookResizerCreated FlowHooks action
fvcHooks (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n) (ControlPosition -> Value
resizeParams ControlPosition
position))
        , (DOMRef -> action) -> Attribute model action
forall action model. (DOMRef -> action) -> Attribute model action
onBeforeDestroyedWith (FlowHooks action -> MisoString -> DOMRef -> action
forall action. FlowHooks action -> MisoString -> DOMRef -> action
hookResizerBeforeDestroyed FlowHooks action
fvcHooks (Node n -> MisoString
forall n. Node n -> MisoString
nodeId Node n
n))
        ]
        []
    resizeParams :: ControlPosition -> Value
resizeParams ControlPosition
position = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ MisoString
"controlPosition" MisoString -> MisoString -> Pair
forall v. ToJSON v => MisoString -> v -> Pair
.= ControlPosition -> MisoString
controlPositionToText ControlPosition
position
      , MisoString
"minWidth" MisoString -> Double -> Pair
forall v. ToJSON v => MisoString -> v -> Pair
.= Double
rcMinWidth
      , MisoString
"minHeight" MisoString -> Double -> Pair
forall v. ToJSON v => MisoString -> v -> Pair
.= Double
rcMinHeight
      , MisoString
"keepAspectRatio" MisoString -> Bool -> Pair
forall v. ToJSON v => MisoString -> v -> Pair
.= Bool
rcKeepAspectRatio
      ]
      [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
      [ (MisoString
"maxWidth" MisoString -> Double -> Pair
forall v. ToJSON v => MisoString -> v -> Pair
.=) (Double -> Pair) -> Maybe Double -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
rcMaxWidth
      , (MisoString
"maxHeight" MisoString -> Double -> Pair
forall v. ToJSON v => MisoString -> v -> Pair
.=) (Double -> Pair) -> Maybe Double -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
rcMaxHeight
      ]
-----------------------------------------------------------------------------