-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Flow.Utils.Marker
-- License     :  BSD3-style (see the file LICENSE)
--
-- Pure port of @utils\/marker.ts@ from @\@xyflow\/system@.
----------------------------------------------------------------------------
module Miso.Flow.Utils.Marker
  ( getMarkerId
  , createMarkerIds
  ) where
-----------------------------------------------------------------------------
import           Data.List (sortBy)
import           Data.Maybe (mapMaybe)
import           Data.Ord (comparing)
import qualified Data.Set as S
import           Prelude
-----------------------------------------------------------------------------
import           Miso.String (MisoString, intercalate)
-----------------------------------------------------------------------------
import           Miso.Flow.Internal.JSNum (jsShow)
import           Miso.Flow.Types
-----------------------------------------------------------------------------
-- | Stable id for a marker; port of @getMarkerId@. Inline markers are
-- keyed by their sorted @key=value@ fields (matching the TS object-key
-- serialization), marker references use their name directly.
getMarkerId :: Maybe EdgeMarkerType -> Maybe MisoString -> MisoString
getMarkerId :: Maybe EdgeMarkerType -> Maybe MisoString -> MisoString
getMarkerId Maybe EdgeMarkerType
Nothing Maybe MisoString
_ = MisoString
""
getMarkerId (Just (MarkerRef MisoString
name)) Maybe MisoString
_ = MisoString
name
getMarkerId (Just (Marker EdgeMarker
m)) Maybe MisoString
flowId =
  MisoString
-> (MisoString -> MisoString) -> Maybe MisoString -> MisoString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MisoString
"" (MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"__") Maybe MisoString
flowId MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString -> [MisoString] -> MisoString
intercalate MisoString
"&" (EdgeMarker -> [MisoString]
markerFields EdgeMarker
m)
-----------------------------------------------------------------------------
-- | The marker's present fields as @key=value@ pairs in (TS
-- @Object.keys(marker).sort()@) alphabetical key order.
markerFields :: EdgeMarker -> [MisoString]
markerFields :: EdgeMarker -> [MisoString]
markerFields 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
..} =
  ((MisoString, Maybe MisoString) -> Maybe MisoString)
-> [(MisoString, Maybe MisoString)] -> [MisoString]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (MisoString, Maybe MisoString) -> Maybe MisoString
forall {a}. (Semigroup a, IsString a) => (a, Maybe a) -> Maybe a
render
    -- alphabetical: color, height, markerUnits, orient, strokeWidth, type, width
    [ (MisoString
"color", Maybe MisoString
markerColor)
    , (MisoString
"height", Double -> MisoString
jsShow (Double -> MisoString) -> Maybe Double -> Maybe MisoString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
markerHeight)
    , (MisoString
"markerUnits", Maybe MisoString
markerUnits)
    , (MisoString
"orient", Maybe MisoString
markerOrient)
    , (MisoString
"strokeWidth", Double -> MisoString
jsShow (Double -> MisoString) -> Maybe Double -> Maybe MisoString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
markerStrokeWidth)
    , (MisoString
"type", MisoString -> Maybe MisoString
forall a. a -> Maybe a
Just (MarkerType -> MisoString
markerTypeToText MarkerType
markerType))
    , (MisoString
"width", Double -> MisoString
jsShow (Double -> MisoString) -> Maybe Double -> Maybe MisoString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
markerWidth)
    ]
  where
    render :: (a, Maybe a) -> Maybe a
render (a
_, Maybe a
Nothing) = Maybe a
forall a. Maybe a
Nothing
    render (a
k, Just a
v) = a -> Maybe a
forall a. a -> Maybe a
Just (a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"=" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
v)
-----------------------------------------------------------------------------
-- | All distinct inline markers used by the given edges, with their ids;
-- port of @createMarkerIds@.
createMarkerIds
  :: [Edge e]
  -> Maybe MisoString
  -- ^ flow id
  -> Maybe MisoString
  -- ^ default color
  -> Maybe EdgeMarkerType
  -- ^ default marker start
  -> Maybe EdgeMarkerType
  -- ^ default marker end
  -> [MarkerProps]
createMarkerIds :: forall e.
[Edge e]
-> Maybe MisoString
-> Maybe MisoString
-> Maybe EdgeMarkerType
-> Maybe EdgeMarkerType
-> [MarkerProps]
createMarkerIds [Edge e]
edges Maybe MisoString
flowId Maybe MisoString
defaultColor Maybe EdgeMarkerType
defaultMarkerStart Maybe EdgeMarkerType
defaultMarkerEnd =
  (MarkerProps -> MarkerProps -> Ordering)
-> [MarkerProps] -> [MarkerProps]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((MarkerProps -> MisoString)
-> MarkerProps -> MarkerProps -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing MarkerProps -> MisoString
markerPropsId) (Set MisoString -> [Edge e] -> [MarkerProps]
forall {e}. Set MisoString -> [Edge e] -> [MarkerProps]
go Set MisoString
forall a. Set a
S.empty [Edge e]
edges)
  where
    go :: Set MisoString -> [Edge e] -> [MarkerProps]
go Set MisoString
_ [] = []
    go Set MisoString
seen (Edge e
e : [Edge e]
rest) =
      let candidates :: [Maybe EdgeMarkerType]
candidates =
            [ Maybe EdgeMarkerType
-> Maybe EdgeMarkerType -> Maybe EdgeMarkerType
forall {a}. Maybe a -> Maybe a -> Maybe a
orDefault (Edge e -> Maybe EdgeMarkerType
forall e. Edge e -> Maybe EdgeMarkerType
edgeMarkerStart Edge e
e) Maybe EdgeMarkerType
defaultMarkerStart
            , Maybe EdgeMarkerType
-> Maybe EdgeMarkerType -> Maybe EdgeMarkerType
forall {a}. Maybe a -> Maybe a -> Maybe a
orDefault (Edge e -> Maybe EdgeMarkerType
forall e. Edge e -> Maybe EdgeMarkerType
edgeMarkerEnd Edge e
e) Maybe EdgeMarkerType
defaultMarkerEnd
            ]
          (Set MisoString
seen', [MarkerProps]
props) = ((Set MisoString, [MarkerProps])
 -> Maybe EdgeMarkerType -> (Set MisoString, [MarkerProps]))
-> (Set MisoString, [MarkerProps])
-> [Maybe EdgeMarkerType]
-> (Set MisoString, [MarkerProps])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Set MisoString, [MarkerProps])
-> Maybe EdgeMarkerType -> (Set MisoString, [MarkerProps])
step (Set MisoString
seen, []) [Maybe EdgeMarkerType]
candidates
      in [MarkerProps] -> [MarkerProps]
forall a. [a] -> [a]
reverse [MarkerProps]
props [MarkerProps] -> [MarkerProps] -> [MarkerProps]
forall a. Semigroup a => a -> a -> a
<> Set MisoString -> [Edge e] -> [MarkerProps]
go Set MisoString
seen' [Edge e]
rest
    orDefault :: Maybe a -> Maybe a -> Maybe a
orDefault Maybe a
m Maybe a
d = case Maybe a
m of
      Just a
x -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
      Maybe a
Nothing -> Maybe a
d
    step :: (Set MisoString, [MarkerProps])
-> Maybe EdgeMarkerType -> (Set MisoString, [MarkerProps])
step (Set MisoString
seen, [MarkerProps]
acc) = \case
      Just (Marker EdgeMarker
m) ->
        let markerId :: MisoString
markerId = Maybe EdgeMarkerType -> Maybe MisoString -> MisoString
getMarkerId (EdgeMarkerType -> Maybe EdgeMarkerType
forall a. a -> Maybe a
Just (EdgeMarker -> EdgeMarkerType
Marker EdgeMarker
m)) Maybe MisoString
flowId
        in if MisoString
markerId MisoString -> Set MisoString -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set MisoString
seen
             then (Set MisoString
seen, [MarkerProps]
acc)
             else
               ( MisoString -> Set MisoString -> Set MisoString
forall a. Ord a => a -> Set a -> Set a
S.insert MisoString
markerId Set MisoString
seen
               , MisoString -> EdgeMarker -> MarkerProps
MarkerProps MisoString
markerId
                   EdgeMarker
m { markerColor =
                         case markerColor m of
                           Just MisoString
c -> MisoString -> Maybe MisoString
forall a. a -> Maybe a
Just MisoString
c
                           Maybe MisoString
Nothing -> Maybe MisoString
defaultColor }
                 MarkerProps -> [MarkerProps] -> [MarkerProps]
forall a. a -> [a] -> [a]
: [MarkerProps]
acc
               )
      Maybe EdgeMarkerType
_ -> (Set MisoString
seen, [MarkerProps]
acc)
-----------------------------------------------------------------------------