diff --git a/common/src/Common/Route.hs b/common/src/Common/Route.hs index 9491dc7..b27dba3 100644 --- a/common/src/Common/Route.hs +++ b/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" diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal index b4f4358..325882a 100644 --- a/frontend/frontend.cabal +++ b/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 diff --git a/frontend/src/Frontend.hs b/frontend/src/Frontend.hs index 7a6749d..f103d60 100644 --- a/frontend/src/Frontend.hs +++ b/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 diff --git a/frontend/src/Frontend/Examples/DragAndDropList/DragAndDropList.hs b/frontend/src/Frontend/Examples/DragAndDropList/DragAndDropList.hs new file mode 100644 index 0000000..e51a785 --- /dev/null +++ b/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] diff --git a/frontend/src/Frontend/Examples/DragAndDropList/Main.hs b/frontend/src/Frontend/Examples/DragAndDropList/Main.hs new file mode 100644 index 0000000..cb42280 --- /dev/null +++ b/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;" + ]