-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Flow.Utils.Store
-- License     :  BSD3-style (see the file LICENSE)
--
-- Pure port of @utils\/store.ts@ from @\@xyflow\/system@: turning user
-- nodes into internal nodes ('adoptUserNodes'), keeping absolute
-- positions up to date, parent expansion, and the connection lookup.
--
-- The only part of the original left on the JavaScript side of the
-- bridge is @updateNodeInternals@' DOM measurement; its results are
-- merged back with 'applyMeasurement'.
----------------------------------------------------------------------------
module Miso.Flow.Utils.Store
  ( UpdateNodesOptions (..)
  , defaultUpdateNodesOptions
  , AdoptUserNodesReturn (..)
  , adoptUserNodes
  , updateAbsolutePositions
  , isManualZIndexMode
  , ParentExpandChild (..)
  , handleExpandParent
  , updateConnectionLookup
  , applyMeasurement
  , NodeMeasurement (..)
  ) where
-----------------------------------------------------------------------------
import qualified Data.Map.Strict as M
import           Data.Maybe (fromMaybe, isNothing)
import           Prelude
-----------------------------------------------------------------------------
import           Miso.Flow.Constants (infiniteExtent)
import           Miso.Flow.Types
import           Miso.Flow.Utils.General
import           Miso.Flow.Utils.Graph (getNodePositionWithOrigin)
-----------------------------------------------------------------------------
selectedNodeZ :: Double
selectedNodeZ :: Double
selectedNodeZ = Double
1000
-----------------------------------------------------------------------------
rootParentZIncrement :: Double
rootParentZIncrement :: Double
rootParentZIncrement = Double
10
-----------------------------------------------------------------------------
-- | Options shared by 'adoptUserNodes' and 'updateAbsolutePositions';
-- port of @UpdateNodesOptions@ (the @defaults@ field is a function here).
data UpdateNodesOptions n = UpdateNodesOptions
  { forall n. UpdateNodesOptions n -> NodeOrigin
unoNodeOrigin           :: !NodeOrigin
  , forall n. UpdateNodesOptions n -> CoordinateExtent
unoNodeExtent           :: !CoordinateExtent
  , forall n. UpdateNodesOptions n -> Bool
unoElevateNodesOnSelect :: !Bool
  , forall n. UpdateNodesOptions n -> ZIndexMode
unoZIndexMode           :: !ZIndexMode
  , forall n. UpdateNodesOptions n -> Node n -> Node n
unoDefaults             :: Node n -> Node n
    -- ^ applied to each user node before adoption (TS spreads a partial
    -- node over it)
  , forall n. UpdateNodesOptions n -> Bool
unoCheckEquality        :: !Bool
  }
-----------------------------------------------------------------------------
defaultUpdateNodesOptions :: UpdateNodesOptions n
defaultUpdateNodesOptions :: forall n. UpdateNodesOptions n
defaultUpdateNodesOptions = UpdateNodesOptions
  { unoNodeOrigin :: NodeOrigin
unoNodeOrigin = NodeOrigin
defaultOrigin
  , unoNodeExtent :: CoordinateExtent
unoNodeExtent = CoordinateExtent
infiniteExtent
  , unoElevateNodesOnSelect :: Bool
unoElevateNodesOnSelect = Bool
True
  , unoZIndexMode :: ZIndexMode
unoZIndexMode = ZIndexMode
ZIndexBasic
  , unoDefaults :: Node n -> Node n
unoDefaults = Node n -> Node n
forall a. a -> a
id
  , unoCheckEquality :: Bool
unoCheckEquality = Bool
True
  }
-----------------------------------------------------------------------------
data AdoptUserNodesReturn = AdoptUserNodesReturn
  { AdoptUserNodesReturn -> Bool
adoptNodesInitialized :: !Bool
  , AdoptUserNodesReturn -> Bool
adoptHasSelectedNodes :: !Bool
  } deriving (Int -> AdoptUserNodesReturn -> ShowS
[AdoptUserNodesReturn] -> ShowS
AdoptUserNodesReturn -> String
(Int -> AdoptUserNodesReturn -> ShowS)
-> (AdoptUserNodesReturn -> String)
-> ([AdoptUserNodesReturn] -> ShowS)
-> Show AdoptUserNodesReturn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AdoptUserNodesReturn -> ShowS
showsPrec :: Int -> AdoptUserNodesReturn -> ShowS
$cshow :: AdoptUserNodesReturn -> String
show :: AdoptUserNodesReturn -> String
$cshowList :: [AdoptUserNodesReturn] -> ShowS
showList :: [AdoptUserNodesReturn] -> ShowS
Show, AdoptUserNodesReturn -> AdoptUserNodesReturn -> Bool
(AdoptUserNodesReturn -> AdoptUserNodesReturn -> Bool)
-> (AdoptUserNodesReturn -> AdoptUserNodesReturn -> Bool)
-> Eq AdoptUserNodesReturn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AdoptUserNodesReturn -> AdoptUserNodesReturn -> Bool
== :: AdoptUserNodesReturn -> AdoptUserNodesReturn -> Bool
$c/= :: AdoptUserNodesReturn -> AdoptUserNodesReturn -> Bool
/= :: AdoptUserNodesReturn -> AdoptUserNodesReturn -> Bool
Eq)
-----------------------------------------------------------------------------
isManualZIndexMode :: ZIndexMode -> Bool
isManualZIndexMode :: ZIndexMode -> Bool
isManualZIndexMode = (ZIndexMode -> ZIndexMode -> Bool
forall a. Eq a => a -> a -> Bool
== ZIndexMode
ZIndexManual)
-----------------------------------------------------------------------------
calculateZ :: Node n -> Double -> ZIndexMode -> Double
calculateZ :: forall n. Node n -> Double -> ZIndexMode -> Double
calculateZ Node n
n Double
selectedZ ZIndexMode
zIndexMode
  | ZIndexMode -> Bool
isManualZIndexMode ZIndexMode
zIndexMode = Double
zIndex
  | Bool
otherwise = Double
zIndex Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (if Node n -> Bool
forall n. Node n -> Bool
nodeSelected Node n
n then Double
selectedZ else Double
0)
  where
    zIndex :: Double
zIndex = case Node n -> Maybe Double
forall n. Node n -> Maybe Double
nodeZIndex Node n
n of
      Just Double
z | Double -> Bool
isNumeric Double
z -> Double
z
      Maybe Double
_ -> Double
0
-----------------------------------------------------------------------------
-- | Build the internal 'NodeLookup' \/ 'ParentLookup' from user nodes;
-- port of @adoptUserNodes@. The previous lookup preserves measured
-- dimensions and DOM-measured handle bounds across updates (standing in
-- for the TS reference-equality cache, using 'Eq' instead).
adoptUserNodes
  :: Eq n
  => [Node n]
  -> NodeLookup n
  -- ^ previous lookup (pass 'M.empty' initially)
  -> UpdateNodesOptions n
  -> (NodeLookup n, ParentLookup n, AdoptUserNodesReturn)
adoptUserNodes :: forall n.
Eq n =>
[Node n]
-> NodeLookup n
-> UpdateNodesOptions n
-> (NodeLookup n, ParentLookup n, AdoptUserNodesReturn)
adoptUserNodes [Node n]
nodes NodeLookup n
prevLookup opts :: UpdateNodesOptions n
opts@UpdateNodesOptions {Bool
CoordinateExtent
NodeOrigin
ZIndexMode
Node n -> Node n
unoNodeOrigin :: forall n. UpdateNodesOptions n -> NodeOrigin
unoNodeExtent :: forall n. UpdateNodesOptions n -> CoordinateExtent
unoElevateNodesOnSelect :: forall n. UpdateNodesOptions n -> Bool
unoZIndexMode :: forall n. UpdateNodesOptions n -> ZIndexMode
unoDefaults :: forall n. UpdateNodesOptions n -> Node n -> Node n
unoCheckEquality :: forall n. UpdateNodesOptions n -> Bool
unoNodeOrigin :: NodeOrigin
unoNodeExtent :: CoordinateExtent
unoElevateNodesOnSelect :: Bool
unoZIndexMode :: ZIndexMode
unoDefaults :: Node n -> Node n
unoCheckEquality :: Bool
..} =
  (NodeLookup n, ParentLookup n, AdoptUserNodesReturn, RootIndex)
-> (NodeLookup n, ParentLookup n, AdoptUserNodesReturn)
forall {a} {b} {c} {d}. (a, b, c, d) -> (a, b, c)
finish (((NodeLookup n, ParentLookup n, AdoptUserNodesReturn, RootIndex)
 -> Node n
 -> (NodeLookup n, ParentLookup n, AdoptUserNodesReturn, RootIndex))
-> (NodeLookup n, ParentLookup n, AdoptUserNodesReturn, RootIndex)
-> [Node n]
-> (NodeLookup n, ParentLookup n, AdoptUserNodesReturn, RootIndex)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (NodeLookup n, ParentLookup n, AdoptUserNodesReturn, RootIndex)
-> Node n
-> (NodeLookup n, ParentLookup n, AdoptUserNodesReturn, RootIndex)
step (NodeLookup n
forall k a. Map k a
M.empty, ParentLookup n
forall k a. Map k a
M.empty, AdoptUserNodesReturn
initial, Int -> RootIndex
RootIndex Int
0) [Node n]
nodes)
  where
    initial :: AdoptUserNodesReturn
initial = Bool -> Bool -> AdoptUserNodesReturn
AdoptUserNodesReturn (Bool -> Bool
not ([Node n] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node n]
nodes)) Bool
False
    selectedZ :: Double
selectedZ =
      if Bool
unoElevateNodesOnSelect Bool -> Bool -> Bool
&& Bool -> Bool
not (ZIndexMode -> Bool
isManualZIndexMode ZIndexMode
unoZIndexMode)
        then Double
selectedNodeZ
        else Double
0
    finish :: (a, b, c, d) -> (a, b, c)
finish (a
nl, b
pl, c
ret, d
_) = (a
nl, b
pl, c
ret)
    step :: (NodeLookup n, ParentLookup n, AdoptUserNodesReturn, RootIndex)
-> Node n
-> (NodeLookup n, ParentLookup n, AdoptUserNodesReturn, RootIndex)
step (NodeLookup n
nodeLookup, ParentLookup n
parentLookup, AdoptUserNodesReturn
ret, RootIndex
rootIndex) Node n
userNode0 =
      let userNode :: Node n
userNode = Node n -> Node n
unoDefaults Node n
userNode0
          prev :: Maybe (InternalNode n)
prev = NodeId -> NodeLookup n -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Node n -> NodeId
forall n. Node n -> NodeId
nodeId Node n
userNode) NodeLookup n
prevLookup
          internal :: InternalNode n
internal = case Maybe (InternalNode n)
prev of
            Just InternalNode n
p
              | Bool
unoCheckEquality
              , InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
p Node n -> Node n -> Bool
forall a. Eq a => a -> a -> Bool
== Node n
userNode -> InternalNode n
p
            Maybe (InternalNode n)
_ ->
              let positionWithOrigin :: XYPosition
positionWithOrigin =
                    Node n -> NodeOrigin -> XYPosition
forall n. Node n -> NodeOrigin -> XYPosition
getNodePositionWithOrigin Node n
userNode NodeOrigin
unoNodeOrigin
                  extent :: CoordinateExtent
extent = case Node n -> Maybe NodeExtent
forall n. Node n -> Maybe NodeExtent
nodeExtent Node n
userNode of
                    Just (ExtentCoordinates CoordinateExtent
ce) -> CoordinateExtent
ce
                    Maybe NodeExtent
_ -> CoordinateExtent
unoNodeExtent
                  clampedPosition :: XYPosition
clampedPosition = XYPosition -> CoordinateExtent -> Dimensions -> XYPosition
clampPosition
                    XYPosition
positionWithOrigin CoordinateExtent
extent (Node n -> Dimensions
forall n. Node n -> Dimensions
getNodeDimensions Node n
userNode)
              in InternalNode
                { internalUser :: Node n
internalUser = Node n
userNode
                , internalMeasured :: Measured
internalMeasured = Measured
                    { measuredWidth :: Maybe Double
measuredWidth = Measured -> Maybe Double
measuredWidth (Measured -> Maybe Double) -> Maybe Measured -> Maybe Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node n -> Maybe Measured
forall n. Node n -> Maybe Measured
nodeMeasured Node n
userNode
                    , measuredHeight :: Maybe Double
measuredHeight = Measured -> Maybe Double
measuredHeight (Measured -> Maybe Double) -> Maybe Measured -> Maybe Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Node n -> Maybe Measured
forall n. Node n -> Maybe Measured
nodeMeasured Node n
userNode
                    }
                , internalPositionAbsolute :: XYPosition
internalPositionAbsolute = XYPosition
clampedPosition
                , internalZ :: Double
internalZ = Node n -> Double -> ZIndexMode -> Double
forall n. Node n -> Double -> ZIndexMode -> Double
calculateZ Node n
userNode Double
selectedZ ZIndexMode
unoZIndexMode
                , internalRootParentIndex :: Maybe Int
internalRootParentIndex = Maybe Int
forall a. Maybe a
Nothing
                , internalHandleBounds :: Maybe NodeHandleBounds
internalHandleBounds = Node n -> Maybe (InternalNode n) -> Maybe NodeHandleBounds
forall n.
Node n -> Maybe (InternalNode n) -> Maybe NodeHandleBounds
parseHandles Node n
userNode Maybe (InternalNode n)
prev
                , internalBounds :: Maybe NodeBounds
internalBounds = Maybe NodeBounds
forall a. Maybe a
Nothing
                }
          uninitialized :: Bool
uninitialized =
            (Maybe Double -> Bool
forall a. Maybe a -> Bool
isNothing (Measured -> Maybe Double
measuredWidth (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
internal))
              Bool -> Bool -> Bool
|| Maybe Double -> Bool
forall a. Maybe a -> Bool
isNothing (Measured -> Maybe Double
measuredHeight (InternalNode n -> Measured
forall n. InternalNode n -> Measured
internalMeasured InternalNode n
internal)))
            Bool -> Bool -> Bool
&& Bool -> Bool
not (Node n -> Bool
forall n. Node n -> Bool
nodeHidden Node n
userNode)
          ret' :: AdoptUserNodesReturn
ret' = AdoptUserNodesReturn
            { adoptNodesInitialized :: Bool
adoptNodesInitialized =
                AdoptUserNodesReturn -> Bool
adoptNodesInitialized AdoptUserNodesReturn
ret Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
uninitialized
            , adoptHasSelectedNodes :: Bool
adoptHasSelectedNodes =
                AdoptUserNodesReturn -> Bool
adoptHasSelectedNodes AdoptUserNodesReturn
ret Bool -> Bool -> Bool
|| Node n -> Bool
forall n. Node n -> Bool
nodeSelected Node n
userNode
            }
          nodeLookup' :: NodeLookup n
nodeLookup' = NodeId -> InternalNode n -> NodeLookup n -> NodeLookup n
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Node n -> NodeId
forall n. Node n -> NodeId
nodeId Node n
userNode) InternalNode n
internal NodeLookup n
nodeLookup
          (NodeLookup n
nodeLookup'', ParentLookup n
parentLookup', RootIndex
rootIndex') =
            case Node n -> Maybe NodeId
forall n. Node n -> Maybe NodeId
nodeParentId Node n
userNode of
              Just NodeId
_ ->
                InternalNode n
-> NodeLookup n
-> ParentLookup n
-> UpdateNodesOptions n
-> Maybe RootIndex
-> (NodeLookup n, ParentLookup n, RootIndex)
forall n.
InternalNode n
-> NodeLookup n
-> ParentLookup n
-> UpdateNodesOptions n
-> Maybe RootIndex
-> (NodeLookup n, ParentLookup n, RootIndex)
updateChildNode InternalNode n
internal NodeLookup n
nodeLookup' ParentLookup n
parentLookup UpdateNodesOptions n
opts (RootIndex -> Maybe RootIndex
forall a. a -> Maybe a
Just RootIndex
rootIndex)
              Maybe NodeId
Nothing -> (NodeLookup n
nodeLookup', ParentLookup n
parentLookup, RootIndex
rootIndex)
      in (NodeLookup n
nodeLookup'', ParentLookup n
parentLookup', AdoptUserNodesReturn
ret', RootIndex
rootIndex')
-----------------------------------------------------------------------------
-- | Port of @parseHandles@: use the node's declared handles when
-- present; otherwise keep previously measured bounds when the node
-- already carries measured dimensions.
parseHandles :: Node n -> Maybe (InternalNode n) -> Maybe NodeHandleBounds
parseHandles :: forall n.
Node n -> Maybe (InternalNode n) -> Maybe NodeHandleBounds
parseHandles Node n
userNode Maybe (InternalNode n)
prev =
  case Node n -> Maybe [NodeHandle]
forall n. Node n -> Maybe [NodeHandle]
nodeHandles Node n
userNode of
    Maybe [NodeHandle]
Nothing
      | Maybe Measured -> Bool
forall a. Maybe a -> Bool
isNothing (Node n -> Maybe Measured
forall n. Node n -> Maybe Measured
nodeMeasured Node n
userNode) -> Maybe NodeHandleBounds
forall a. Maybe a
Nothing
      | Bool
otherwise -> InternalNode n -> Maybe NodeHandleBounds
forall n. InternalNode n -> Maybe NodeHandleBounds
internalHandleBounds (InternalNode n -> Maybe NodeHandleBounds)
-> Maybe (InternalNode n) -> Maybe NodeHandleBounds
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (InternalNode n)
prev
    Just [NodeHandle]
handles ->
      NodeHandleBounds -> Maybe NodeHandleBounds
forall a. a -> Maybe a
Just NodeHandleBounds
        { nhbSource :: Maybe [Handle]
nhbSource = [Handle] -> Maybe [Handle]
forall a. a -> Maybe a
Just [ Handle
h | Handle
h <- [Handle]
hs, Handle -> HandleType
hType Handle
h HandleType -> HandleType -> Bool
forall a. Eq a => a -> a -> Bool
== HandleType
SourceHandle ]
        , nhbTarget :: Maybe [Handle]
nhbTarget = [Handle] -> Maybe [Handle]
forall a. a -> Maybe a
Just [ Handle
h | Handle
h <- [Handle]
hs, Handle -> HandleType
hType Handle
h HandleType -> HandleType -> Bool
forall a. Eq a => a -> a -> Bool
== HandleType
TargetHandle ]
        }
      where
        hs :: [Handle]
hs = (NodeHandle -> Handle) -> [NodeHandle] -> [Handle]
forall a b. (a -> b) -> [a] -> [b]
map NodeHandle -> Handle
toHandle [NodeHandle]
handles
        toHandle :: NodeHandle -> Handle
toHandle NodeHandle
nh = Handle
          { hId :: Maybe NodeId
hId = NodeHandle -> Maybe NodeId
nhId NodeHandle
nh
          , hNodeId :: NodeId
hNodeId = Node n -> NodeId
forall n. Node n -> NodeId
nodeId Node n
userNode
          , hX :: Double
hX = NodeHandle -> Double
nhX NodeHandle
nh
          , hY :: Double
hY = NodeHandle -> Double
nhY NodeHandle
nh
          , hPosition :: Position
hPosition = NodeHandle -> Position
nhPosition NodeHandle
nh
          , hType :: HandleType
hType = NodeHandle -> HandleType
nhType NodeHandle
nh
          , hWidth :: Double
hWidth = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (NodeHandle -> Maybe Double
nhWidth NodeHandle
nh)
          , hHeight :: Double
hHeight = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (NodeHandle -> Maybe Double
nhHeight NodeHandle
nh)
          }
-----------------------------------------------------------------------------
newtype RootIndex = RootIndex Int
-----------------------------------------------------------------------------
-- | Update @positionAbsolute@ and z-index of a child node and the parent
-- lookup; port of @updateChildNode@.
updateChildNode
  :: InternalNode n
  -> NodeLookup n
  -> ParentLookup n
  -> UpdateNodesOptions n
  -> Maybe RootIndex
  -> (NodeLookup n, ParentLookup n, RootIndex)
updateChildNode :: forall n.
InternalNode n
-> NodeLookup n
-> ParentLookup n
-> UpdateNodesOptions n
-> Maybe RootIndex
-> (NodeLookup n, ParentLookup n, RootIndex)
updateChildNode InternalNode n
n NodeLookup n
nodeLookup ParentLookup n
parentLookup UpdateNodesOptions {Bool
CoordinateExtent
NodeOrigin
ZIndexMode
Node n -> Node n
unoNodeOrigin :: forall n. UpdateNodesOptions n -> NodeOrigin
unoNodeExtent :: forall n. UpdateNodesOptions n -> CoordinateExtent
unoElevateNodesOnSelect :: forall n. UpdateNodesOptions n -> Bool
unoZIndexMode :: forall n. UpdateNodesOptions n -> ZIndexMode
unoDefaults :: forall n. UpdateNodesOptions n -> Node n -> Node n
unoCheckEquality :: forall n. UpdateNodesOptions n -> Bool
unoNodeOrigin :: NodeOrigin
unoNodeExtent :: CoordinateExtent
unoElevateNodesOnSelect :: Bool
unoZIndexMode :: ZIndexMode
unoDefaults :: Node n -> Node n
unoCheckEquality :: Bool
..} Maybe RootIndex
mRootIndex =
  case NodeId -> NodeLookup n -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeId
parentId NodeLookup n
nodeLookup of
    Maybe (InternalNode n)
Nothing ->
      -- parent nodes must come before their children in the nodes array
      (NodeLookup n
nodeLookup, ParentLookup n
parentLookup, RootIndex -> Maybe RootIndex -> RootIndex
forall a. a -> Maybe a -> a
fromMaybe (Int -> RootIndex
RootIndex Int
0) Maybe RootIndex
mRootIndex)
    Just InternalNode n
parentNode0 ->
      let parentLookup' :: ParentLookup n
parentLookup' = (NodeLookup n -> NodeLookup n -> NodeLookup n)
-> NodeId -> NodeLookup n -> ParentLookup n -> ParentLookup n
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith NodeLookup n -> NodeLookup n -> NodeLookup n
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union NodeId
parentId
            (NodeId -> InternalNode n -> NodeLookup n
forall k a. k -> a -> Map k a
M.singleton (Node n -> NodeId
forall n. Node n -> NodeId
nodeId (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n)) InternalNode n
n) ParentLookup n
parentLookup
          -- root parent z elevation (auto mode only)
          (InternalNode n
parentNode, NodeLookup n
nodeLookup1, RootIndex
rootIndex1) =
            case Maybe RootIndex
mRootIndex of
              Just (RootIndex Int
i)
                | Maybe NodeId -> Bool
forall a. Maybe a -> Bool
isNothing (Node n -> Maybe NodeId
forall n. Node n -> Maybe NodeId
nodeParentId (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
parentNode0))
                , Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (InternalNode n -> Maybe Int
forall n. InternalNode n -> Maybe Int
internalRootParentIndex InternalNode n
parentNode0)
                , ZIndexMode
unoZIndexMode ZIndexMode -> ZIndexMode -> Bool
forall a. Eq a => a -> a -> Bool
== ZIndexMode
ZIndexAuto ->
                    let i' :: Int
i' = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                        p' :: InternalNode n
p' = InternalNode n
parentNode0
                          { internalRootParentIndex = Just i'
                          , internalZ = internalZ parentNode0
                              + fromIntegral i' * rootParentZIncrement
                          }
                    in (InternalNode n
p', NodeId -> InternalNode n -> NodeLookup n -> NodeLookup n
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert NodeId
parentId InternalNode n
p' NodeLookup n
nodeLookup, Int -> RootIndex
RootIndex Int
i')
              Maybe RootIndex
_ ->
                let idx :: RootIndex
idx = case InternalNode n -> Maybe Int
forall n. InternalNode n -> Maybe Int
internalRootParentIndex InternalNode n
parentNode0 of
                      Just Int
i -> Int -> RootIndex
RootIndex Int
i
                      Maybe Int
Nothing -> RootIndex -> Maybe RootIndex -> RootIndex
forall a. a -> Maybe a -> a
fromMaybe (Int -> RootIndex
RootIndex Int
0) Maybe RootIndex
mRootIndex
                in (InternalNode n
parentNode0, NodeLookup n
nodeLookup, RootIndex
idx)
          selectedZ :: Double
selectedZ =
            if Bool
unoElevateNodesOnSelect Bool -> Bool -> Bool
&& Bool -> Bool
not (ZIndexMode -> Bool
isManualZIndexMode ZIndexMode
unoZIndexMode)
              then Double
selectedNodeZ
              else Double
0
          (Double
x, Double
y, Double
z) = InternalNode n
-> InternalNode n
-> NodeOrigin
-> CoordinateExtent
-> Double
-> ZIndexMode
-> (Double, Double, Double)
forall n.
InternalNode n
-> InternalNode n
-> NodeOrigin
-> CoordinateExtent
-> Double
-> ZIndexMode
-> (Double, Double, Double)
calculateChildXYZ InternalNode n
n InternalNode n
parentNode
            NodeOrigin
unoNodeOrigin CoordinateExtent
unoNodeExtent Double
selectedZ ZIndexMode
unoZIndexMode
          XYPosition Double
ax Double
ay = InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute InternalNode n
n
          positionChanged :: Bool
positionChanged = Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
ax Bool -> Bool -> Bool
|| Double
y Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
ay
          nodeLookup2 :: NodeLookup n
nodeLookup2
            | Bool
positionChanged Bool -> Bool -> Bool
|| Double
z Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= InternalNode n -> Double
forall n. InternalNode n -> Double
internalZ InternalNode n
n =
                NodeId -> InternalNode n -> NodeLookup n -> NodeLookup n
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Node n -> NodeId
forall n. Node n -> NodeId
nodeId (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n))
                  InternalNode n
n { internalPositionAbsolute =
                        if positionChanged then XYPosition x y
                        else internalPositionAbsolute n
                    , internalZ = z
                    }
                  NodeLookup n
nodeLookup1
            | Bool
otherwise = NodeLookup n
nodeLookup1
      in (NodeLookup n
nodeLookup2, ParentLookup n
parentLookup', RootIndex
rootIndex1)
  where
    parentId :: NodeId
parentId = NodeId -> Maybe NodeId -> NodeId
forall a. a -> Maybe a -> a
fromMaybe NodeId
"" (Node n -> Maybe NodeId
forall n. Node n -> Maybe NodeId
nodeParentId (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n))
-----------------------------------------------------------------------------
calculateChildXYZ
  :: InternalNode n
  -> InternalNode n
  -> NodeOrigin
  -> CoordinateExtent
  -> Double
  -> ZIndexMode
  -> (Double, Double, Double)
calculateChildXYZ :: forall n.
InternalNode n
-> InternalNode n
-> NodeOrigin
-> CoordinateExtent
-> Double
-> ZIndexMode
-> (Double, Double, Double)
calculateChildXYZ InternalNode n
childNode InternalNode n
parentNode NodeOrigin
nodeOrigin' CoordinateExtent
nodeExtent' Double
selectedZ ZIndexMode
zIndexMode =
  (XYPosition -> Double
xyX XYPosition
absolutePosition', XYPosition -> Double
xyY XYPosition
absolutePosition', Double
zOut)
  where
    child :: Node n
child = InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
childNode
    XYPosition Double
parentX Double
parentY = InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute InternalNode n
parentNode
    childDimensions :: Dimensions
childDimensions = InternalNode n -> Dimensions
forall n. InternalNode n -> Dimensions
getInternalNodeDimensions InternalNode n
childNode
    positionWithOrigin :: XYPosition
positionWithOrigin = Node n -> NodeOrigin -> XYPosition
forall n. Node n -> NodeOrigin -> XYPosition
getNodePositionWithOrigin Node n
child NodeOrigin
nodeOrigin'
    clampedPosition :: XYPosition
clampedPosition = case Node n -> Maybe NodeExtent
forall n. Node n -> Maybe NodeExtent
nodeExtent Node n
child of
      Just (ExtentCoordinates CoordinateExtent
ce) ->
        XYPosition -> CoordinateExtent -> Dimensions -> XYPosition
clampPosition XYPosition
positionWithOrigin CoordinateExtent
ce Dimensions
childDimensions
      Maybe NodeExtent
_ -> XYPosition
positionWithOrigin
    absolutePosition :: XYPosition
absolutePosition = XYPosition -> CoordinateExtent -> Dimensions -> XYPosition
clampPosition
      (Double -> Double -> XYPosition
XYPosition (Double
parentX Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyX XYPosition
clampedPosition) (Double
parentY Double -> Double -> Double
forall a. Num a => a -> a -> a
+ XYPosition -> Double
xyY XYPosition
clampedPosition))
      CoordinateExtent
nodeExtent'
      Dimensions
childDimensions
    absolutePosition' :: XYPosition
absolutePosition' = case Node n -> Maybe NodeExtent
forall n. Node n -> Maybe NodeExtent
nodeExtent Node n
child of
      Just NodeExtent
ExtentParent ->
        XYPosition -> Dimensions -> InternalNode n -> XYPosition
forall n. XYPosition -> Dimensions -> InternalNode n -> XYPosition
clampPositionToParent XYPosition
absolutePosition Dimensions
childDimensions InternalNode n
parentNode
      Maybe NodeExtent
_ -> XYPosition
absolutePosition
    childZ :: Double
childZ = Node n -> Double -> ZIndexMode -> Double
forall n. Node n -> Double -> ZIndexMode -> Double
calculateZ Node n
child Double
selectedZ ZIndexMode
zIndexMode
    parentZ :: Double
parentZ = InternalNode n -> Double
forall n. InternalNode n -> Double
internalZ InternalNode n
parentNode
    zOut :: Double
zOut = if Double
parentZ Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
childZ then Double
parentZ Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1 else Double
childZ
-----------------------------------------------------------------------------
-- | Refresh @positionAbsolute@ of every node in the lookup; port of
-- @updateAbsolutePositions@.
updateAbsolutePositions
  :: NodeLookup n
  -> UpdateNodesOptions n
  -> NodeLookup n
updateAbsolutePositions :: forall n. NodeLookup n -> UpdateNodesOptions n -> NodeLookup n
updateAbsolutePositions NodeLookup n
nodeLookup opts :: UpdateNodesOptions n
opts@UpdateNodesOptions {Bool
CoordinateExtent
NodeOrigin
ZIndexMode
Node n -> Node n
unoNodeOrigin :: forall n. UpdateNodesOptions n -> NodeOrigin
unoNodeExtent :: forall n. UpdateNodesOptions n -> CoordinateExtent
unoElevateNodesOnSelect :: forall n. UpdateNodesOptions n -> Bool
unoZIndexMode :: forall n. UpdateNodesOptions n -> ZIndexMode
unoDefaults :: forall n. UpdateNodesOptions n -> Node n -> Node n
unoCheckEquality :: forall n. UpdateNodesOptions n -> Bool
unoNodeOrigin :: NodeOrigin
unoNodeExtent :: CoordinateExtent
unoElevateNodesOnSelect :: Bool
unoZIndexMode :: ZIndexMode
unoDefaults :: Node n -> Node n
unoCheckEquality :: Bool
..} =
  (NodeLookup n -> InternalNode n -> NodeLookup n)
-> NodeLookup n -> [InternalNode n] -> NodeLookup n
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl NodeLookup n -> InternalNode n -> NodeLookup n
step NodeLookup n
nodeLookup (NodeLookup n -> [InternalNode n]
forall k a. Map k a -> [a]
M.elems NodeLookup n
nodeLookup)
  where
    step :: NodeLookup n -> InternalNode n -> NodeLookup n
step NodeLookup n
nl InternalNode n
n =
      case Node n -> Maybe NodeId
forall n. Node n -> Maybe NodeId
nodeParentId (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n) of
        Just NodeId
_ ->
          let (NodeLookup n
nl', ParentLookup n
_, RootIndex
_) = InternalNode n
-> NodeLookup n
-> ParentLookup n
-> UpdateNodesOptions n
-> Maybe RootIndex
-> (NodeLookup n, ParentLookup n, RootIndex)
forall n.
InternalNode n
-> NodeLookup n
-> ParentLookup n
-> UpdateNodesOptions n
-> Maybe RootIndex
-> (NodeLookup n, ParentLookup n, RootIndex)
updateChildNode InternalNode n
n NodeLookup n
nl ParentLookup n
forall k a. Map k a
M.empty UpdateNodesOptions n
opts Maybe RootIndex
forall a. Maybe a
Nothing
          in NodeLookup n
nl'
        Maybe NodeId
Nothing ->
          let u :: Node n
u = InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
n
              positionWithOrigin :: XYPosition
positionWithOrigin = Node n -> NodeOrigin -> XYPosition
forall n. Node n -> NodeOrigin -> XYPosition
getNodePositionWithOrigin Node n
u NodeOrigin
unoNodeOrigin
              extent :: CoordinateExtent
extent = case Node n -> Maybe NodeExtent
forall n. Node n -> Maybe NodeExtent
nodeExtent Node n
u of
                Just (ExtentCoordinates CoordinateExtent
ce) -> CoordinateExtent
ce
                Maybe NodeExtent
_ -> CoordinateExtent
unoNodeExtent
              clampedPosition :: XYPosition
clampedPosition =
                XYPosition -> CoordinateExtent -> Dimensions -> XYPosition
clampPosition XYPosition
positionWithOrigin CoordinateExtent
extent (Node n -> Dimensions
forall n. Node n -> Dimensions
getNodeDimensions Node n
u)
          in NodeId -> InternalNode n -> NodeLookup n -> NodeLookup n
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Node n -> NodeId
forall n. Node n -> NodeId
nodeId Node n
u) InternalNode n
n { internalPositionAbsolute = clampedPosition } NodeLookup n
nl
-----------------------------------------------------------------------------
-- | A child that may cause its parent to expand.
data ParentExpandChild = ParentExpandChild
  { ParentExpandChild -> NodeId
pecId       :: !NodeId
  , ParentExpandChild -> NodeId
pecParentId :: !NodeId
  , ParentExpandChild -> Rect
pecRect     :: !Rect
  } deriving (Int -> ParentExpandChild -> ShowS
[ParentExpandChild] -> ShowS
ParentExpandChild -> String
(Int -> ParentExpandChild -> ShowS)
-> (ParentExpandChild -> String)
-> ([ParentExpandChild] -> ShowS)
-> Show ParentExpandChild
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParentExpandChild -> ShowS
showsPrec :: Int -> ParentExpandChild -> ShowS
$cshow :: ParentExpandChild -> String
show :: ParentExpandChild -> String
$cshowList :: [ParentExpandChild] -> ShowS
showList :: [ParentExpandChild] -> ShowS
Show, ParentExpandChild -> ParentExpandChild -> Bool
(ParentExpandChild -> ParentExpandChild -> Bool)
-> (ParentExpandChild -> ParentExpandChild -> Bool)
-> Eq ParentExpandChild
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParentExpandChild -> ParentExpandChild -> Bool
== :: ParentExpandChild -> ParentExpandChild -> Bool
$c/= :: ParentExpandChild -> ParentExpandChild -> Bool
/= :: ParentExpandChild -> ParentExpandChild -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Changes needed to expand parents so the given children fit; port of
-- @handleExpandParent@.
handleExpandParent
  :: [ParentExpandChild]
  -> NodeLookup n
  -> ParentLookup n
  -> NodeOrigin
  -> [NodeChange n]
handleExpandParent :: forall n.
[ParentExpandChild]
-> NodeLookup n -> ParentLookup n -> NodeOrigin -> [NodeChange n]
handleExpandParent [ParentExpandChild]
children NodeLookup n
nodeLookup ParentLookup n
parentLookup NodeOrigin
nodeOrigin' =
  ((NodeId, (Rect, InternalNode n)) -> [NodeChange n])
-> [(NodeId, (Rect, InternalNode n))] -> [NodeChange n]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NodeId, (Rect, InternalNode n)) -> [NodeChange n]
forall {n} {n}. (NodeId, (Rect, InternalNode n)) -> [NodeChange n]
expand (Map NodeId (Rect, InternalNode n)
-> [(NodeId, (Rect, InternalNode n))]
forall k a. Map k a -> [(k, a)]
M.toList Map NodeId (Rect, InternalNode n)
parentExpansions)
  where
    parentExpansions :: Map NodeId (Rect, InternalNode n)
parentExpansions = (Map NodeId (Rect, InternalNode n)
 -> ParentExpandChild -> Map NodeId (Rect, InternalNode n))
-> Map NodeId (Rect, InternalNode n)
-> [ParentExpandChild]
-> Map NodeId (Rect, InternalNode n)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map NodeId (Rect, InternalNode n)
-> ParentExpandChild -> Map NodeId (Rect, InternalNode n)
step Map NodeId (Rect, InternalNode n)
forall k a. Map k a
M.empty [ParentExpandChild]
children
      where
        step :: Map NodeId (Rect, InternalNode n)
-> ParentExpandChild -> Map NodeId (Rect, InternalNode n)
step Map NodeId (Rect, InternalNode n)
acc ParentExpandChild
child =
          case NodeId -> NodeLookup n -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ParentExpandChild -> NodeId
pecParentId ParentExpandChild
child) NodeLookup n
nodeLookup of
            Maybe (InternalNode n)
Nothing -> Map NodeId (Rect, InternalNode n)
acc
            Just InternalNode n
parent ->
              let parentRect :: Rect
parentRect = case NodeId
-> Map NodeId (Rect, InternalNode n)
-> Maybe (Rect, InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ParentExpandChild -> NodeId
pecParentId ParentExpandChild
child) Map NodeId (Rect, InternalNode n)
acc of
                    Just (Rect
r, InternalNode n
_) -> Rect
r
                    Maybe (Rect, InternalNode n)
Nothing -> InternalNode n -> Rect
forall n. InternalNode n -> Rect
internalNodeToRect InternalNode n
parent
                  expandedRect :: Rect
expandedRect = Rect -> Rect -> Rect
getBoundsOfRects Rect
parentRect (ParentExpandChild -> Rect
pecRect ParentExpandChild
child)
              in NodeId
-> (Rect, InternalNode n)
-> Map NodeId (Rect, InternalNode n)
-> Map NodeId (Rect, InternalNode n)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (ParentExpandChild -> NodeId
pecParentId ParentExpandChild
child) (Rect
expandedRect, InternalNode n
parent) Map NodeId (Rect, InternalNode n)
acc
    expand :: (NodeId, (Rect, InternalNode n)) -> [NodeChange n]
expand (NodeId
parentId, (Rect
expandedRect, InternalNode n
parent)) =
      let positionAbsolute :: XYPosition
positionAbsolute = InternalNode n -> XYPosition
forall n. InternalNode n -> XYPosition
internalPositionAbsolute InternalNode n
parent
          dimensions :: Dimensions
dimensions = InternalNode n -> Dimensions
forall n. InternalNode n -> Dimensions
getInternalNodeDimensions InternalNode n
parent
          NodeOrigin Double
ox Double
oy =
            NodeOrigin -> Maybe NodeOrigin -> NodeOrigin
forall a. a -> Maybe a -> a
fromMaybe NodeOrigin
nodeOrigin' (Node n -> Maybe NodeOrigin
forall n. Node n -> Maybe NodeOrigin
nodeOrigin (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
parent))
          jsRound' :: a -> b
jsRound' a
v = Integer -> b
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
round a
v :: Integer)
          xChange :: Double
xChange =
            if Rect -> Double
rectX Rect
expandedRect Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< XYPosition -> Double
xyX XYPosition
positionAbsolute
              then Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
jsRound' (Double -> Double
forall a. Num a => a -> a
abs (XYPosition -> Double
xyX XYPosition
positionAbsolute Double -> Double -> Double
forall a. Num a => a -> a -> a
- Rect -> Double
rectX Rect
expandedRect))
              else Double
0
          yChange :: Double
yChange =
            if Rect -> Double
rectY Rect
expandedRect Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< XYPosition -> Double
xyY XYPosition
positionAbsolute
              then Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
jsRound' (Double -> Double
forall a. Num a => a -> a
abs (XYPosition -> Double
xyY XYPosition
positionAbsolute Double -> Double -> Double
forall a. Num a => a -> a -> a
- Rect -> Double
rectY Rect
expandedRect))
              else Double
0
          newWidth :: Double
newWidth = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Dimensions -> Double
dimensionsWidth Dimensions
dimensions) (Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
jsRound' (Rect -> Double
rectWidth Rect
expandedRect))
          newHeight :: Double
newHeight = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Dimensions -> Double
dimensionsHeight Dimensions
dimensions) (Double -> Double
forall {a} {b}. (RealFrac a, Num b) => a -> b
jsRound' (Rect -> Double
rectHeight Rect
expandedRect))
          widthChange :: Double
widthChange = (Double
newWidth Double -> Double -> Double
forall a. Num a => a -> a -> a
- Dimensions -> Double
dimensionsWidth Dimensions
dimensions) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ox
          heightChange :: Double
heightChange = (Double
newHeight Double -> Double -> Double
forall a. Num a => a -> a -> a
- Dimensions -> Double
dimensionsHeight Dimensions
dimensions) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
oy
          parentPos :: XYPosition
parentPos = Node n -> XYPosition
forall n. Node n -> XYPosition
nodePosition (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
parent)
          positionChanges :: [NodeChange n]
positionChanges
            | Double
xChange Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
|| Double
yChange Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
|| Double
widthChange Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0 Bool -> Bool -> Bool
|| Double
heightChange Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0 =
                NodeId
-> Maybe XYPosition
-> Maybe XYPosition
-> Maybe Bool
-> NodeChange n
forall n.
NodeId
-> Maybe XYPosition
-> Maybe XYPosition
-> Maybe Bool
-> NodeChange n
NodePositionChange NodeId
parentId
                  (XYPosition -> Maybe XYPosition
forall a. a -> Maybe a
Just (Double -> Double -> XYPosition
XYPosition
                    (XYPosition -> Double
xyX XYPosition
parentPos Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
xChange Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
widthChange)
                    (XYPosition -> Double
xyY XYPosition
parentPos Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
yChange Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
heightChange)))
                  Maybe XYPosition
forall a. Maybe a
Nothing
                  Maybe Bool
forall a. Maybe a
Nothing
                NodeChange n -> [NodeChange n] -> [NodeChange n]
forall a. a -> [a] -> [a]
: -- move children in the opposite direction so they stay put
                [ NodeId
-> Maybe XYPosition
-> Maybe XYPosition
-> Maybe Bool
-> NodeChange n
forall n.
NodeId
-> Maybe XYPosition
-> Maybe XYPosition
-> Maybe Bool
-> NodeChange n
NodePositionChange (Node n -> NodeId
forall n. Node n -> NodeId
nodeId (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
childNode))
                    (XYPosition -> Maybe XYPosition
forall a. a -> Maybe a
Just (Double -> Double -> XYPosition
XYPosition
                      (XYPosition -> Double
xyX (Node n -> XYPosition
forall n. Node n -> XYPosition
nodePosition (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
childNode)) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
xChange)
                      (XYPosition -> Double
xyY (Node n -> XYPosition
forall n. Node n -> XYPosition
nodePosition (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
childNode)) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
yChange)))
                    Maybe XYPosition
forall a. Maybe a
Nothing
                    Maybe Bool
forall a. Maybe a
Nothing
                | InternalNode n
childNode <- [InternalNode n]
-> (NodeLookup n -> [InternalNode n])
-> Maybe (NodeLookup n)
-> [InternalNode n]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] NodeLookup n -> [InternalNode n]
forall k a. Map k a -> [a]
M.elems (NodeId -> ParentLookup n -> Maybe (NodeLookup n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeId
parentId ParentLookup n
parentLookup)
                , NodeId -> [NodeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem (Node n -> NodeId
forall n. Node n -> NodeId
nodeId (InternalNode n -> Node n
forall n. InternalNode n -> Node n
internalUser InternalNode n
childNode)) ((ParentExpandChild -> NodeId) -> [ParentExpandChild] -> [NodeId]
forall a b. (a -> b) -> [a] -> [b]
map ParentExpandChild -> NodeId
pecId [ParentExpandChild]
children)
                ]
            | Bool
otherwise = []
          dimensionChanges :: [NodeChange n]
dimensionChanges
            | Dimensions -> Double
dimensionsWidth Dimensions
dimensions Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Rect -> Double
rectWidth Rect
expandedRect
                Bool -> Bool -> Bool
|| Dimensions -> Double
dimensionsHeight Dimensions
dimensions Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Rect -> Double
rectHeight Rect
expandedRect
                Bool -> Bool -> Bool
|| Double
xChange Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0 Bool -> Bool -> Bool
|| Double
yChange Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0 =
                [ NodeId
-> Maybe Dimensions -> Maybe Bool -> SetAttributes -> NodeChange n
forall n.
NodeId
-> Maybe Dimensions -> Maybe Bool -> SetAttributes -> NodeChange n
NodeDimensionChange NodeId
parentId
                    (Dimensions -> Maybe Dimensions
forall a. a -> Maybe a
Just (Double -> Double -> Dimensions
Dimensions
                      (Double
newWidth Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (if Double
xChange Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0 then Double
ox Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
xChange Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
widthChange else Double
0))
                      (Double
newHeight Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (if Double
yChange Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0 then Double
oy Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
yChange Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
heightChange else Double
0))))
                    Maybe Bool
forall a. Maybe a
Nothing
                    SetAttributes
SetAttributesBoth
                ]
            | Bool
otherwise = []
      in [NodeChange n]
forall {n}. [NodeChange n]
positionChanges [NodeChange n] -> [NodeChange n] -> [NodeChange n]
forall a. Semigroup a => a -> a -> a
<> [NodeChange n]
forall {n}. [NodeChange n]
dimensionChanges
-----------------------------------------------------------------------------
-- | Build the 'ConnectionLookup' and 'EdgeLookup' from edges; port of
-- @updateConnectionLookup@.
updateConnectionLookup :: [Edge e] -> (ConnectionLookup, EdgeLookup e)
updateConnectionLookup :: forall e. [Edge e] -> (ConnectionLookup, EdgeLookup e)
updateConnectionLookup [Edge e]
edges =
  ((ConnectionLookup, EdgeLookup e)
 -> Edge e -> (ConnectionLookup, EdgeLookup e))
-> (ConnectionLookup, EdgeLookup e)
-> [Edge e]
-> (ConnectionLookup, EdgeLookup e)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (ConnectionLookup, EdgeLookup e)
-> Edge e -> (ConnectionLookup, EdgeLookup e)
forall {e}.
(ConnectionLookup, Map NodeId (Edge e))
-> Edge e -> (ConnectionLookup, Map NodeId (Edge e))
step (ConnectionLookup
forall k a. Map k a
M.empty, EdgeLookup e
forall k a. Map k a
M.empty) [Edge e]
edges
  where
    step :: (ConnectionLookup, Map NodeId (Edge e))
-> Edge e -> (ConnectionLookup, Map NodeId (Edge e))
step (ConnectionLookup
connectionLookup, Map NodeId (Edge e)
edgeLookup) Edge e
e =
      let sourceNode :: NodeId
sourceNode = Edge e -> NodeId
forall e. Edge e -> NodeId
edgeSource Edge e
e
          targetNode :: NodeId
targetNode = Edge e -> NodeId
forall e. Edge e -> NodeId
edgeTarget Edge e
e
          sourceHandle :: Maybe NodeId
sourceHandle = Edge e -> Maybe NodeId
forall e. Edge e -> Maybe NodeId
edgeSourceHandle Edge e
e
          targetHandle :: Maybe NodeId
targetHandle = Edge e -> Maybe NodeId
forall e. Edge e -> Maybe NodeId
edgeTargetHandle Edge e
e
          conn :: HandleConnection
conn = HandleConnection
            { handleConnection :: Connection
handleConnection = Connection
                { connectionSource :: NodeId
connectionSource = NodeId
sourceNode
                , connectionTarget :: NodeId
connectionTarget = NodeId
targetNode
                , connectionSourceHandle :: Maybe NodeId
connectionSourceHandle = Maybe NodeId
sourceHandle
                , connectionTargetHandle :: Maybe NodeId
connectionTargetHandle = Maybe NodeId
targetHandle
                }
            , handleConnectionEdgeId :: NodeId
handleConnectionEdgeId = Edge e -> NodeId
forall e. Edge e -> NodeId
edgeId Edge e
e
            }
          textOf :: Maybe NodeId -> NodeId
textOf = NodeId -> Maybe NodeId -> NodeId
forall a. a -> Maybe a -> a
fromMaybe NodeId
"null"
          sourceKey :: NodeId
sourceKey = [NodeId] -> NodeId
forall a. Monoid a => [a] -> a
mconcat
            [ NodeId
sourceNode, NodeId
"-", Maybe NodeId -> NodeId
textOf Maybe NodeId
sourceHandle
            , NodeId
"--", NodeId
targetNode, NodeId
"-", Maybe NodeId -> NodeId
textOf Maybe NodeId
targetHandle ]
          targetKey :: NodeId
targetKey = [NodeId] -> NodeId
forall a. Monoid a => [a] -> a
mconcat
            [ NodeId
targetNode, NodeId
"-", Maybe NodeId -> NodeId
textOf Maybe NodeId
targetHandle
            , NodeId
"--", NodeId
sourceNode, NodeId
"-", Maybe NodeId -> NodeId
textOf Maybe NodeId
sourceHandle ]
          add :: k
-> k
-> Maybe k
-> k
-> Map k (Map k HandleConnection)
-> Map k (Map k HandleConnection)
add k
ty k
nid Maybe k
mHandle k
key Map k (Map k HandleConnection)
cl =
            let keys :: [k]
keys =
                  [ k
nid, k
nid k -> k -> k
forall a. Semigroup a => a -> a -> a
<> k
"-" k -> k -> k
forall a. Semigroup a => a -> a -> a
<> k
ty ]
                  [k] -> [k] -> [k]
forall a. Semigroup a => a -> a -> a
<> [ k
nid k -> k -> k
forall a. Semigroup a => a -> a -> a
<> k
"-" k -> k -> k
forall a. Semigroup a => a -> a -> a
<> k
ty k -> k -> k
forall a. Semigroup a => a -> a -> a
<> k
"-" k -> k -> k
forall a. Semigroup a => a -> a -> a
<> k
h | Just k
h <- [Maybe k
mHandle] ]
            in (Map k (Map k HandleConnection)
 -> k -> Map k (Map k HandleConnection))
-> Map k (Map k HandleConnection)
-> [k]
-> Map k (Map k HandleConnection)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                (\Map k (Map k HandleConnection)
acc k
k -> (Map k HandleConnection
 -> Map k HandleConnection -> Map k HandleConnection)
-> k
-> Map k HandleConnection
-> Map k (Map k HandleConnection)
-> Map k (Map k HandleConnection)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Map k HandleConnection
-> Map k HandleConnection -> Map k HandleConnection
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union k
k (k -> HandleConnection -> Map k HandleConnection
forall k a. k -> a -> Map k a
M.singleton k
key HandleConnection
conn) Map k (Map k HandleConnection)
acc)
                Map k (Map k HandleConnection)
cl [k]
keys
          connectionLookup' :: ConnectionLookup
connectionLookup' =
            NodeId
-> NodeId
-> Maybe NodeId
-> NodeId
-> ConnectionLookup
-> ConnectionLookup
forall {k} {k}.
(Ord k, Ord k, Semigroup k, IsString k) =>
k
-> k
-> Maybe k
-> k
-> Map k (Map k HandleConnection)
-> Map k (Map k HandleConnection)
add NodeId
"target" NodeId
targetNode Maybe NodeId
targetHandle NodeId
sourceKey
              (NodeId
-> NodeId
-> Maybe NodeId
-> NodeId
-> ConnectionLookup
-> ConnectionLookup
forall {k} {k}.
(Ord k, Ord k, Semigroup k, IsString k) =>
k
-> k
-> Maybe k
-> k
-> Map k (Map k HandleConnection)
-> Map k (Map k HandleConnection)
add NodeId
"source" NodeId
sourceNode Maybe NodeId
sourceHandle NodeId
targetKey ConnectionLookup
connectionLookup)
      in (ConnectionLookup
connectionLookup', NodeId -> Edge e -> Map NodeId (Edge e) -> Map NodeId (Edge e)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Edge e -> NodeId
forall e. Edge e -> NodeId
edgeId Edge e
e) Edge e
e Map NodeId (Edge e)
edgeLookup)
-----------------------------------------------------------------------------
-- | DOM measurement of one node, as reported over the bridge by the
-- JavaScript side's @updateNodeInternals@.
data NodeMeasurement = NodeMeasurement
  { NodeMeasurement -> NodeId
nmId               :: !NodeId
  , NodeMeasurement -> Dimensions
nmDimensions       :: !Dimensions
  , NodeMeasurement -> Maybe NodeHandleBounds
nmHandleBounds     :: !(Maybe NodeHandleBounds)
  , NodeMeasurement -> Maybe XYPosition
nmPositionAbsolute :: !(Maybe XYPosition)
  } deriving (Int -> NodeMeasurement -> ShowS
[NodeMeasurement] -> ShowS
NodeMeasurement -> String
(Int -> NodeMeasurement -> ShowS)
-> (NodeMeasurement -> String)
-> ([NodeMeasurement] -> ShowS)
-> Show NodeMeasurement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeMeasurement -> ShowS
showsPrec :: Int -> NodeMeasurement -> ShowS
$cshow :: NodeMeasurement -> String
show :: NodeMeasurement -> String
$cshowList :: [NodeMeasurement] -> ShowS
showList :: [NodeMeasurement] -> ShowS
Show, NodeMeasurement -> NodeMeasurement -> Bool
(NodeMeasurement -> NodeMeasurement -> Bool)
-> (NodeMeasurement -> NodeMeasurement -> Bool)
-> Eq NodeMeasurement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeMeasurement -> NodeMeasurement -> Bool
== :: NodeMeasurement -> NodeMeasurement -> Bool
$c/= :: NodeMeasurement -> NodeMeasurement -> Bool
/= :: NodeMeasurement -> NodeMeasurement -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Merge measured dimensions and handle bounds into the lookup (the
-- Haskell half of @updateNodeInternals@).
applyMeasurement :: [NodeMeasurement] -> NodeLookup n -> NodeLookup n
applyMeasurement :: forall n. [NodeMeasurement] -> NodeLookup n -> NodeLookup n
applyMeasurement [NodeMeasurement]
ms NodeLookup n
nodeLookup = (NodeLookup n -> NodeMeasurement -> NodeLookup n)
-> NodeLookup n -> [NodeMeasurement] -> NodeLookup n
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl NodeLookup n -> NodeMeasurement -> NodeLookup n
forall {n}.
Map NodeId (InternalNode n)
-> NodeMeasurement -> Map NodeId (InternalNode n)
step NodeLookup n
nodeLookup [NodeMeasurement]
ms
  where
    step :: Map NodeId (InternalNode n)
-> NodeMeasurement -> Map NodeId (InternalNode n)
step Map NodeId (InternalNode n)
nl NodeMeasurement {Maybe NodeHandleBounds
Maybe XYPosition
NodeId
Dimensions
nmId :: NodeMeasurement -> NodeId
nmDimensions :: NodeMeasurement -> Dimensions
nmHandleBounds :: NodeMeasurement -> Maybe NodeHandleBounds
nmPositionAbsolute :: NodeMeasurement -> Maybe XYPosition
nmId :: NodeId
nmDimensions :: Dimensions
nmHandleBounds :: Maybe NodeHandleBounds
nmPositionAbsolute :: Maybe XYPosition
..} =
      case NodeId -> Map NodeId (InternalNode n) -> Maybe (InternalNode n)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NodeId
nmId Map NodeId (InternalNode n)
nl of
        Maybe (InternalNode n)
Nothing -> Map NodeId (InternalNode n)
nl
        Just InternalNode n
n -> NodeId
-> InternalNode n
-> Map NodeId (InternalNode n)
-> Map NodeId (InternalNode n)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert NodeId
nmId
          InternalNode n
n { internalMeasured = Measured
                (Just (dimensionsWidth nmDimensions))
                (Just (dimensionsHeight nmDimensions))
            , internalHandleBounds = case nmHandleBounds of
                Just NodeHandleBounds
hb -> NodeHandleBounds -> Maybe NodeHandleBounds
forall a. a -> Maybe a
Just NodeHandleBounds
hb
                Maybe NodeHandleBounds
Nothing -> InternalNode n -> Maybe NodeHandleBounds
forall n. InternalNode n -> Maybe NodeHandleBounds
internalHandleBounds InternalNode n
n
            , internalPositionAbsolute =
                fromMaybe (internalPositionAbsolute n) nmPositionAbsolute
            }
          Map NodeId (InternalNode n)
nl
-----------------------------------------------------------------------------