Add sortable component / hoook

marlowe-playground-client/spago.dhall

@@ -32,8 +32,10 @@ You can edit this file as you like.
   , "gen"
   , "halogen"
   , "halogen-hooks"
+  , "halogen-hooks-extra"
   , "halogen-subscriptions"
   , "http-methods"
+  , "infinite-lists"
   , "integers"
   , "js-timers"
   , "json-helpers"

marlowe-playground-client/src/Contrib/Data/Unfoldable.purs

@@ -0,0 +1,48 @@
+module Contrib.Data.Unfoldable where
+
+import Prelude
+import Data.Foldable (length)
+import Data.FoldableWithIndex (class FoldableWithIndex, foldrWithIndex)
+import Data.List (List(..), uncons) as List
+import Data.Maybe (Maybe(..))
+import Data.Tuple.Nested ((/\))
+import Data.Unfoldable (class Unfoldable, unfoldr)
+
+type Move = { from :: Int, to :: Int }
+
+-- | This function resides here in the `Unfoldable` namespace because
+-- | `unfoldable` depends on `foldable-traversable` package and `Data`
+-- | namespace seems to general for it.
+move
+  :: forall a f g
+   . FoldableWithIndex Int f
+  => Unfoldable g
+  => Move
+  -> f a
+  -> Maybe (g a)
+move { from, to } foldable = do
+  when (to > length foldable)
+    Nothing
+  let
+    foldStep idx elem acc
+      | idx == from = acc { elem = Just elem }
+      | otherwise = acc { items = List.Cons elem acc.items }
+
+    { elem, items } = foldrWithIndex foldStep { elem: Nothing, items: List.Nil }
+      foldable
+  let
+    unfoldStep seed@{ idx, elem, items } = do
+      let
+        idx' = idx + 1
+
+        result
+          | idx == to = Just (elem /\ seed { idx = idx' })
+          | otherwise = do
+              { head, tail } <- List.uncons items
+              Just (head /\ seed { idx = idx', items = tail })
+      result
+  -- | There is no UnfoldableWithIndex unfortunatelly... yet:
+  -- | https://github.com/purescript/purescript-foldable-traversable/issues/84
+  -- | so we have to carry the index ourselves.
+  seed <- { idx: 0, elem: _, items } <$> elem
+  pure $ unfoldr unfoldStep seed

marlowe-playground-client/src/Contrib/Halogen/Sortable.purs

@@ -0,0 +1,175 @@
+module Contrib.Halogen.Components.Sortable where
+
+import Prelude
+
+import Contrib.Data.Unfoldable (Move) as Unfoldable
+import Control.Alternative (guard) as Alternative
+import Control.Monad.Maybe.Extra (hoistMaybe)
+import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
+import Control.Monad.Trans.Class (lift)
+import Data.Lens (Lens')
+import Data.Lens (set, view) as Lens
+import Data.List.Infinite (List, unfold) as Infinite
+import Data.Maybe (Maybe(..), isJust)
+import Data.Tuple (Tuple(..))
+import Data.Tuple.Nested ((/\))
+import Effect.Class (class MonadEffect, liftEffect)
+import Halogen (HalogenM)
+import Halogen (get, put) as H
+import Halogen.HTML (IProp)
+import Halogen.HTML.Events (onDragEnd, onDragEnter, onDragStart) as Events
+import Web.Event.Event (preventDefault)
+import Web.HTML.Event.DragEvent (DragEvent)
+import Web.HTML.Event.DragEvent (toEvent) as DragEvent
+
+newtype OrderingVersion
+  = OrderingVersion Int
+
+derive newtype instance eqOrderingVersion :: Eq OrderingVersion
+
+nextVersion :: OrderingVersion -> OrderingVersion
+nextVersion (OrderingVersion i) = OrderingVersion (i + 1)
+
+-- | We have to keep ordering version because sorting can trigger
+-- | reordering which assynchronously is repainted. If in between
+-- | we trigger some other reordering it is going to be inconsisten
+-- | with the new one so we have to ignore all events till everything is
+-- | repainted
+type State
+  = { orderingVersion :: OrderingVersion, dragging :: Maybe Int }
+
+initialState :: State
+initialState = { orderingVersion: OrderingVersion 0, dragging: Nothing }
+
+data Action
+  = DragStart OrderingVersion DragEvent Int
+  | DragEnd
+  | MoveTo OrderingVersion Int
+
+type DragHandler r action
+  = IProp
+  ( onDragEnd :: DragEvent
+  , onDragEnter :: DragEvent
+  , onDragStart :: DragEvent
+  | r
+  )
+  action
+
+-- | We need this `newtype` because of escaping type variable `r` error.
+-- | The benefit is that we get a Functor out of it.
+newtype DragHandlers action
+  = DragHandlers
+  { onDragEnd :: forall r. DragHandler r action
+  , onDragEnter :: forall r. DragHandler r action
+  , onDragStart :: forall r. DragHandler r action
+  }
+
+instance functorDragHandlers :: Functor DragHandlers where
+  map f (DragHandlers r) =
+    DragHandlers
+      { onDragStart: map f r.onDragStart
+      , onDragEnter: map f r.onDragEnter
+      , onDragEnd: map f r.onDragEnd
+      }
+
+type GenDragHandlers action
+  = Infinite.List (DragHandlers action)
+
+mkGenDragHandlers :: OrderingVersion -> GenDragHandlers Action
+mkGenDragHandlers orderingVersion =
+  Infinite.unfold 0 \idx -> do
+    let
+      onDragStart :: forall r. DragHandler r Action
+      onDragStart =
+        Events.onDragStart \event ->
+          DragStart orderingVersion event idx
+
+      onDragEnd :: forall r. DragHandler r Action
+      onDragEnd = Events.onDragEnd $ const DragEnd
+
+      onDragEnter :: forall r. DragHandler r Action
+      onDragEnter =
+        Events.onDragEnter
+          $ const do
+              -- | The action handler is going to check if
+              -- | idices are different etc.
+              MoveTo orderingVersion idx
+    Tuple
+      ( DragHandlers
+          { onDragStart
+          , onDragEnd
+          , onDragEnter
+          }
+      )
+      (idx + 1)
+
+mkGenDragHandlers'
+  :: forall state. Lens' state State -> state -> GenDragHandlers Action
+mkGenDragHandlers' l = mkGenDragHandlers <<< _.orderingVersion <<< Lens.view l
+
+-- | We provide a reordering function instead of assuming that items
+-- | container is accessible through local state because it is usually
+-- | not the case (it can be in `halogen-store` and local state etc.)
+handleAction
+  :: forall m
+   . MonadEffect m
+  => (Unfoldable.Move -> m Unit)
+  -> Action
+  -> State
+  -> m (Maybe State)
+handleAction handleReordering action state = case action of
+  DragStart orderingVersion event dragging ->
+    if
+      ( orderingVersion == state.orderingVersion && state.dragging /= Just
+          dragging
+      ) then
+      pure $ Just $ state { dragging = Just dragging }
+    else do
+      liftEffect $ preventDefault (DragEvent.toEvent event)
+      pure Nothing
+  DragEnd ->
+    pure
+      $
+        Alternative.guard
+          (isJust state.dragging)
+          $> state { dragging = Nothing }
+  MoveTo orderingVersion idx ->
+    runMaybeT do
+      dragging <- hoistMaybe state.dragging
+      st /\ f <-
+        hoistMaybe $
+          Alternative.guard
+            (state.orderingVersion == orderingVersion && dragging /= idx)
+            $> do
+              let
+                orderingVersion' = nextVersion state.orderingVersion
+
+                state' =
+                  { dragging: Just idx, orderingVersion: orderingVersion' }
+
+                -- f i = fromMaybe i (Unfoldable.moveTo dragging idx i)
+                move = { from: dragging, to: idx }
+              state' /\ move
+      lift $ handleReordering f
+      pure st
+
+handleActionH
+  :: forall action m output slots state
+   . MonadEffect m
+  => (Unfoldable.Move -> HalogenM state action slots output m Unit)
+  -> Lens' state State
+  -> Action
+  -> HalogenM state action slots output m Unit
+handleActionH handleReordering stateL action = do
+  state <- H.get
+  let
+    updated =
+      runMaybeT do
+        state' <- MaybeT $ handleAction handleReordering action $ Lens.view
+          stateL
+          state
+        pure $ Lens.set stateL state' state
+  updated
+    >>= case _ of
+      Just state' -> H.put state'
+      Nothing -> pure unit

marlowe-playground-client/src/Contrib/Halogen/Sortable/Hook.purs

@@ -0,0 +1,138 @@
+module Contrib.Halogen.Components.Sortable.Hook where
+
+import Prelude
+
+import Contrib.Data.Unfoldable (Move) as Unfoldable
+import Contrib.Halogen.Components.Sortable
+  ( DragHandlers(..)
+  , OrderingVersion
+  , initialState
+  , nextVersion
+  ) as Sortable
+import Contrib.Halogen.Components.Sortable (OrderingVersion, GenDragHandlers)
+import Data.List.Infinite (unfold) as Infinite
+import Data.Maybe (Maybe(..), isJust)
+import Data.Tuple.Nested ((/\))
+import Effect.Class (class MonadEffect, liftEffect)
+import Halogen.HTML.Events (onDragEnd, onDragEnter, onDragStart) as Events
+import Halogen.Hooks (class HookNewtype, type (<>), Hook, HookM, UseEffect)
+import Halogen.Hooks as Hooks
+import Halogen.Hooks.Extra.Hooks (UseGet, UseStateFn, useGet, useModifyState_)
+import Web.Event.Event (preventDefault) as Event
+import Web.HTML.Event.DragEvent (toEvent) as DragEvent
+
+foreign import data UseSortable :: Hooks.HookType
+
+type State
+  =
+  { dragging :: Maybe Int
+  , orderingVersion :: Sortable.OrderingVersion
+  , move :: Maybe Unfoldable.Move
+  }
+
+type UseSortable'
+  = UseStateFn State <> UseGet State <> Hooks.Pure
+
+instance newtypeUseSortable :: HookNewtype UseSortable UseSortable'
+
+useSortable
+  :: forall m
+   . MonadEffect m
+  => Hook
+       m
+       UseSortable
+       { dragging :: Maybe Int
+       , genDragHandlers :: GenDragHandlers (HookM m Unit)
+       , reordering ::
+           { move :: Maybe Unfoldable.Move
+           , version :: OrderingVersion
+           }
+       }
+useSortable = Hooks.wrap hook
+  where
+  hook :: Hook m UseSortable' _
+  hook = Hooks.do
+    state /\ modifyState <-
+      useModifyState_
+        { dragging: Sortable.initialState.dragging
+        , orderingVersion: Sortable.initialState.orderingVersion
+        , move: Nothing
+        }
+    getState <- useGet state
+    let
+      genDragHandlers =
+        Infinite.unfold 0 \idx -> do
+          let
+            handlers =
+              Sortable.DragHandlers
+                { onDragStart:
+                    Events.onDragStart \event -> do
+                      { dragging, orderingVersion } <- getState
+                      if
+                        ( orderingVersion == state.orderingVersion && dragging
+                            /= Just idx
+                        ) then
+                        modifyState _ { dragging = Just idx }
+                      else do
+                        liftEffect $ Event.preventDefault
+                          (DragEvent.toEvent event)
+                , onDragEnd:
+                    Events.onDragEnd
+                      $ \_ -> do
+                          { dragging } <- getState
+                          when (isJust dragging) do
+                            modifyState _ { dragging = Nothing }
+                , onDragEnter:
+                    Events.onDragEnter
+                      $ \_ ->
+                          getState
+                            >>= case _ of
+                              { dragging: Just dragging, orderingVersion }
+                                | orderingVersion == state.orderingVersion &&
+                                    dragging /= idx -> do
+                                    let
+                                      orderingVersion' = Sortable.nextVersion
+                                        orderingVersion
+
+                                      move = Just { from: dragging, to: idx }
+
+                                      state' =
+                                        { dragging: Just idx
+                                        , orderingVersion: orderingVersion'
+                                        , move
+                                        }
+                                    modifyState $ const state'
+                              _ -> pure unit
+                }
+          handlers /\ (idx + 1)
+    Hooks.pure
+      { dragging: state.dragging
+      , genDragHandlers
+      , reordering:
+          { move: state.move
+          , version: state.orderingVersion
+          }
+      }
+
+useSortable'
+  :: forall m
+   . MonadEffect m
+  => (Unfoldable.Move -> HookM m Unit)
+  -> Hook
+       m
+       (UseSortable <> UseEffect <> UseEffect)
+       { dragging :: Maybe Int
+       , genDragHandlers :: GenDragHandlers (HookM m Unit)
+       }
+useSortable' handleReordering = Hooks.do
+  { dragging, genDragHandlers, reordering } <- useSortable
+  Hooks.captures { version: reordering.version }
+    $ flip Hooks.useTickEffect do
+        case reordering.move of
+          Just m -> handleReordering m
+          Nothing -> pure unit
+        pure Nothing
+  Hooks.pure
+    { dragging
+    , genDragHandlers
+    }