Add Drag and Drop List example

common/src/Common/Route.hs

@@ -49,6 +49,7 @@ data Example :: * -> * where
   Example_BasicToDo :: Example ()
   Example_Chess :: Example ()
   Example_DragAndDrop :: Example ()
+  Example_DragAndDropList :: Example ()
   Example_FileReader :: Example ()
   Example_ScreenKeyboard :: Example ()
   Example_NasaPod :: Example ()
@@ -74,6 +75,7 @@ fullRouteEncoder = mkFullRouteEncoder (FullRoute_Backend BackendRoute_Missing :/
       Example_BasicToDo -> PathSegment "basictodo" $ unitEncoder mempty
       Example_Chess -> PathSegment "chess" $ unitEncoder mempty
       Example_DragAndDrop -> PathSegment "draganddrop" $ unitEncoder mempty
+      Example_DragAndDropList -> PathSegment "draganddroplist" $ unitEncoder mempty
       Example_FileReader -> PathSegment "filereader" $ unitEncoder mempty
       Example_ScreenKeyboard -> PathSegment "screenkeyboard" $ unitEncoder mempty
       Example_NasaPod -> PathSegment "nasapod" $ unitEncoder mempty
@@ -97,6 +99,7 @@ exampleTitle (Some.Some sec) = case sec of
   Example_BasicToDo -> "Basic To Do List"
   Example_Chess -> "Local Chess Game"
   Example_DragAndDrop -> "Drag n Drop"
+  Example_DragAndDropList -> "Drag n Drop List"
   Example_FileReader -> "File Reader"
   Example_ScreenKeyboard -> "Onscreen Keyboard"
   Example_NasaPod -> "Nasa: Picture of the Day"
@@ -122,6 +125,7 @@ sectionHomepage (Some.Some sec) = sec :/ case sec of
   Example_BasicToDo -> ()
   Example_Chess -> ()
   Example_DragAndDrop -> ()
+  Example_DragAndDropList -> ()
   Example_FileReader -> ()
   Example_ScreenKeyboard -> ()
   Example_NasaPod -> ()
@@ -139,6 +143,8 @@ exampleDescription (Some.Some sec) = case sec of
   Example_Chess -> "A simple chess game to be played against another local player"
   Example_DragAndDrop ->
     "An example to demonstrate Drag and Drop functionality"
+  Example_DragAndDropList -> 
+    "An example of a list that can be reordered with Drag and Drop"
   Example_FileReader ->
     "Read a file on the client using FileReader"
   Example_ScreenKeyboard ->
@@ -188,6 +194,7 @@ exampleSourceCode (sec :=> _) = base <> path <> file
       Example_BasicToDo -> "BasicToDo"
       Example_Chess -> "Chess"
       Example_DragAndDrop -> "DragAndDrop"
+      Example_DragAndDropList -> "DragAndDropList"
       Example_FileReader -> "FileReader"
       Example_ScreenKeyboard -> "ScreenKeyboard"
       Example_NasaPod -> "NasaPod"

frontend/frontend.cabal

@@ -41,6 +41,8 @@ library
     Frontend.Examples.Chess.Main
     Frontend.Examples.DisplayGameUpdates.Main
     Frontend.Examples.DragAndDrop.Main
+    Frontend.Examples.DragAndDropList.Main
+    Frontend.Examples.DragAndDropList.DragAndDropList
     Frontend.Examples.FileReader.Main
     Frontend.Examples.NasaPod.Main
     Frontend.Examples.PegSolitaire.Main
@@ -50,6 +52,7 @@ library
     Frontend.Examples.ECharts.ExamplesData
     Frontend.Examples.WebSocketChat.Main
     Frontend.Examples.WebSocketEcho.Main
+
   ghc-options: -Wall
 
 executable frontend

frontend/src/Frontend.hs

@@ -29,6 +29,7 @@ import qualified Frontend.Examples.BasicToDo.Main as BasicToDo
 import qualified Frontend.Examples.Chess.Main as Chess
 import qualified Frontend.Examples.DisplayGameUpdates.Main as DisplayGameUpdates
 import qualified Frontend.Examples.DragAndDrop.Main as DragAndDrop
+import qualified Frontend.Examples.DragAndDropList.Main as DragAndDropList
 import qualified Frontend.Examples.ECharts.Main as ECharts
 import qualified Frontend.Examples.FileReader.Main as FileReader
 import qualified Frontend.Examples.NasaPod.Main as NasaPod
@@ -66,6 +67,7 @@ examples route _ = subRoute_ $ \case
   Example_BasicToDo -> BasicToDo.app
   Example_Chess -> Chess.app
   Example_DragAndDrop -> DragAndDrop.app
+  Example_DragAndDropList -> DragAndDropList.app
   Example_FileReader -> FileReader.app
   Example_ScreenKeyboard -> ScreenKeyboard.app
   Example_NasaPod -> NasaPod.app

frontend/src/Frontend/Examples/DragAndDropList/DragAndDropList.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Frontend.Examples.DragAndDropList.DragAndDropList (
+  DragEvent (..),
+  DragAndDropConfig (..),
+  DragAndDropConstraints,
+  createDraggableList,
+  createDraggableItem,
+) where
+
+import Control.Monad.Fix (MonadFix)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Reflex.Dom
+
+-- | Events that can occur during drag and drop
+data DragEvent k = DragStart k | DragEnter k | DragLeave k | DragEnd k
+  deriving (Show, Eq)
+
+-- | Constraints required for drag and drop functionality
+type DragAndDropConstraints t m =
+  ( DomBuilder t m
+  , MonadHold t m
+  , MonadFix m
+  , PostBuild t m
+  , MonadSample t (Performable m)
+  , DomBuilderSpace m ~ GhcjsDomSpace
+  )
+
+-- | Configuration for creating a draggable list
+data DragAndDropConfig t m k v = DragAndDropConfig
+  { initialItems :: Map.Map k v
+  , itemWidget :: k -> Dynamic t v -> m (Event t (DragEvent k))
+  }
+
+-- | Creates a draggable list based on the provided configuration
+createDraggableList ::
+  (Ord k, Eq v, DragAndDropConstraints t m) =>
+  DragAndDropConfig t m k v ->
+  m (Dynamic t (Map.Map k v))
+createDraggableList config = do
+  rec items <- foldDyn ($) (initialItems config) updateEvent
+      updateEvent <- draggableList items (itemWidget config)
+  return items
+
+-- | Creates the draggable list widget
+draggableList ::
+  (Ord k, Eq v, DragAndDropConstraints t m) =>
+  Dynamic t (Map.Map k v) ->
+  (k -> Dynamic t v -> m (Event t (DragEvent k))) ->
+  m (Event t (Map.Map k v -> Map.Map k v))
+draggableList items widget = do
+  events <- listWithKey items widget
+  let allEvents = switch . current $ fmap (leftmost . Map.elems) events
+  rec dragState <- foldDyn updateDragState Nothing allEvents
+      let updateEvent = fmapMaybe (uncurry processDropAlpha) $ attach (current dragState) allEvents
+  return updateEvent
+
+-- | Updates the drag state based on drag events
+updateDragState :: Eq k => DragEvent k -> Maybe (k, k) -> Maybe (k, k)
+updateDragState (DragStart src) _ = Just (src, src)
+updateDragState (DragEnter dst) (Just (src, _)) = Just (src, dst)
+updateDragState (DragLeave _) state = state
+updateDragState (DragEnd _) Nothing = Nothing
+updateDragState (DragEnd _) (Just (src, dst)) = if src == dst then Nothing else Just (src, dst)
+updateDragState (DragEnter dst) Nothing = Just (dst, dst)
+
+-- | Processes the drop event and updates the item order
+processDropAlpha :: Ord k => Maybe (k, k) -> DragEvent k -> Maybe (Map.Map k v -> Map.Map k v)
+processDropAlpha (Just (src, dst)) (DragEnd _) | src /= dst = Just $ \m ->
+  let srcItem = Map.findWithDefault (error "Source item not found") src m
+      dstItem = Map.findWithDefault (error "Destination item not found") dst m
+   in Map.insert dst srcItem $ Map.insert src dstItem m
+processDropAlpha _ _ = Nothing
+
+-- | Creates a draggable item widget
+createDraggableItem ::
+  DragAndDropConstraints t m =>
+  k ->
+  Dynamic t T.Text ->
+  T.Text -> -- CSS styles
+  m (Event t (DragEvent k))
+createDraggableItem key contentDyn cssStyles = do
+  (cElement, _) <-
+    elAttr'
+      "div"
+      ( "style" =: cssStyles
+          <> "draggable" =: "true"
+      )
+      $ dynText contentDyn
+  let dragStartEvent = DragStart key <$ domEvent Dragstart cElement
+      dragEnterEvent = DragEnter key <$ domEvent Dragenter cElement
+      dragLeaveEvent = DragLeave key <$ domEvent Dragleave cElement
+      dragEndEvent = DragEnd key <$ domEvent Dragend cElement
+  return $ leftmost [dragStartEvent, dragEnterEvent, dragLeaveEvent, dragEndEvent]

frontend/src/Frontend/Examples/DragAndDropList/Main.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Frontend.Examples.DragAndDropList.Main where
+
+import Control.Monad.Except
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+import Reflex.Dom
+
+import Frontend.Examples.DragAndDropList.DragAndDropList
+
+main :: IO ()
+main = mainWidget app
+
+-- One thing to note here is this will not work on mobile because this example handles click events and not touch events.
+-- To support touch events you can load in some js to handle this explicity, but this is beyond the scope of this example.
+app :: (DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m, Prerender t m) => m ()
+app = do
+  el "h1" $ text "Drag and Drop Demo"
+  prerender_ blank $ do
+    _ <- createDraggableList dragAndDropConfig
+    blank
+
+-- Here we define the configuration that is passed to the draggable list
+dragAndDropConfig :: DragAndDropConstraints t m => DragAndDropConfig t m Int T.Text
+dragAndDropConfig =
+  DragAndDropConfig
+    { initialItems = Map.fromList [(1, "Item 1"), (2, "Item 2"), (3, "Item 3"), (4, "Item 4"), (5, "Item 5")]
+    , itemWidget = \key itemTextDyn -> createDraggableItem key itemTextDyn itemStyle
+    }
+
+-- This is just a helper function to pass the item CSS style
+itemStyle :: T.Text
+itemStyle = T.unwords
+  [ "padding: 1rem;"
+  , "margin: 0.5rem;"
+  , "background-color: #bfdbfe;"
+  , "cursor: move;"
+  , "border: 1px solid #60a5fa;"
+  , "border-radius: 0.25rem;"
+  ]