Porting a Draggable Table example from JS to Purescript-Halogen

Help
, ,
#1

Before I waste anyone’s time, I want to start with the fact that I am an absolute beginner in the world of Purescript, so go easy on me.

I am attempting to use Purescript for as much of my (DApp) project as possible and when Purescript isn’t the right tool, I’d hopefully be using Haskell and Cardano’s Haskell subset called Plutus for the minimal on-chain code that would be required.

I was hoping to avoid having to use the FFI at least for the functionality outlined in the example below: but perhaps the example is just too dynamic and impossible to do in a functional paradigm in this case. I am trying to keep it all fairly low in unnecessary dependencies as well.

Anyway, I have been desperately fighting to try and get this (what I though was a) relatively simple example ported from Javascript/Typescript into my new favorite language: Purescript. I was cruising along methodically until I recently ran into the something I had been trying to avoid: being forced to use Unsafe.Coerce (to poll the mouse position in this case). Obviously, this is an impure operation, so I have been steadily coming to grips with the reality (?) that I will need to try and accomplish this using the FFI or some spooky but necessary Unsafe.Coerce code that can feed the re-ordered data into Halogen?

But, I wonder if someone has some advice for me to get this short example FULLY working in the latest version of Purescript with the latest version of Halogen. Here’s what the simple example looks like in its original form as Javascript:

and here’s what all of the code looks like so far when I try and replicate this small example with my beginner-level code getting as far as I can without help:

import Prelude
import Web.DOM

import Data.Array (deleteAt, insertAt, mapWithIndex, (!!))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Aff.Class (class MonadAff)
import Halogen (Component, ComponentHTML, HalogenM, defaultEval, mkComponent, mkEval, modify_) as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events (onDragOver, onMouseDown, onMouseMove, onMouseUp)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Store.Connect (Connected)
import Halogen.Store.Select as Store
import Halogen.VDom.Driver (runUI)
import Web.DOM.Element (Element)
import Web.DOM.Element (getBoundingClientRect, DOMRect)
import Web.DOM.NonElementParentNode (getElementById)
import Web.HTML.Common (ClassName(..))
import Web.HTML.Event.DragEvent.EventTypes (dragover)
import Web.HTML.Event.DragEvent.EventTypes as MDE
import Web.UIEvent.MouseEvent as MEV
import Web.UIEvent.MouseEvent.EventTypes (mousedown, mousemove, mouseup)
import Web.UIEvent.MouseEvent.EventTypes as MVT

type Input = Unit

deriveState :: Connected Store Input -> Store
deriveState { context } = context

selectStore :: Store.Selector Store Store
selectStore = Store.selectEq \store -> store

type DragState = 
  { index :: Maybe Int
  , originalX :: Int
  , originalY :: Int
  , currentX :: Int
  , currentY :: Int
  , isDragging :: Boolean
  }

type Store = 
  { rows :: Array (Tuple String String)
  , dragState :: DragState
  , dragOverIndex :: Maybe Int
  }

data Action
  = StartDrag Int Int Int Int
  | MoveDrag Int Int
  | DragOver Int Int 
  | EndDrag
  | NoOp

initialStore :: Store
initialStore =  
  { rows: [ Tuple "April Douglas" "Health Educator"
          , Tuple "Salma Mcbride" "Mental Health Counselor"
          , Tuple "Kassandra Donovan" "Makeup Artists"
          , Tuple "Yosef Hartman" "Theatrical and Performance"
          , Tuple "Ronald Mayo" "Plant Etiologist"
          , Tuple "Trey Woolley" "Maxillofacial Surgeon"
          ]
  , dragState: { index: Nothing, originalX: 0, originalY: 0, currentX: 0, currentY: 0, isDragging: false }
  , dragOverIndex: Nothing
  }

component :: forall q m. MonadAff m => H.Component q Unit Void m
component = 
  H.mkComponent
    { initialState
    , render
    , eval: H.mkEval H.defaultEval
        { handleAction = handleAction
        , handleQuery = \_ -> pure Nothing
        , receive = const Nothing
        , initialize = Nothing
        , finalize = Nothing
        }
    }

initialState :: Input -> Store
initialState _ = initialStore

rowHeight :: Int
rowHeight = 50

findDropIndex :: Int -> Maybe Int
findDropIndex currentY =
  let
    rowIndex = currentY `div` rowHeight
  in
    Just rowIndex

render :: forall m. MonadAff m => Store -> H.ComponentHTML Action () m
render state =
  HH.div []
    [ HH.table
        [ HP.class_ (HH.ClassName "draggable-table") ]
        [ HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Name" ], HH.th_ [ HH.text "Occupation" ]]]
        , HH.tbody_ $ mapWithIndex (\index (Tuple name occupation) -> renderRow index name occupation state.dragState.index) state.rows
        ]
    ]

renderRow :: forall m. Int -> String -> String -> Maybe Int -> H.ComponentHTML Action () m
renderRow index name occupation dragging =
  HH.tr
    [ HP.classes $ ClassName <$> ["draggable-table__row"] <>
        if Just index == dragging then ["is-dragging"] else []
    , onMouseDown $ HE.handler MVT.mousedown (\event -> StartDrag index (MEV.clientX event) (MEV.clientY event))
    , onMouseMove $ HE.handler MVT.mousemove (\event -> MoveDrag (MEV.clientX event) (MEV.clientY event))
    , onMouseUp $ HE.handler MVT.mouseup (\_ -> EndDrag)
    , onDragOver $ HE.handler MDE.dragover (\event -> DragOver index (MEV.clientY event))
    , HP.draggable true
    ]
    [ renderCell name, renderCell occupation ]

renderCell :: forall m. String -> H.ComponentHTML Action () m
renderCell content =
  HH.td 
    [ HP.class_ (HH.ClassName "table-cell") ]
    [ HH.text content ]

handleAction :: forall m. MonadAff m => Action -> H.HalogenM Store Action () Void m Unit
handleAction action =
  case action of
    StartDrag index x y ->
      H.modify_ \s -> s { dragState = { index: Just index, originalX: x, originalY: y, currentX: x, currentY: y, isDragging: true }}
    MoveDrag x y ->
      H.modify_ \s -> s { dragState = s.dragState { currentX = x, currentY = y }}
    DragOver mouseY -> 
      H.modify_ \s -> s { dragOverIndex = findDropIndex mouseY }
    EndDrag ->
      H.modify_ \s -> case s.dragState.index of
        Just fromIndex -> case s.dragOverIndex of
          Just toIndex -> s { rows = moveRow fromIndex toIndex s.rows
                            , dragState = resetDragState
                            , dragOverIndex = Nothing }
          Nothing -> s { dragState = resetDragState, dragOverIndex = Nothing }
        Nothing -> s
    NoOp -> pure unit

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  runUI component unit body 

moveRow :: Int -> Int -> Array (Tuple String String) -> Array (Tuple String String)
moveRow from to rows =
  let
    draggedRow = fromMaybe (Tuple "" "") $ rows !! from
    rowsWithoutDragged = fromMaybe rows $ deleteAt from rows
  in
    fromMaybe rowsWithoutDragged $ insertAt to draggedRow rowsWithoutDragged

resetDragState :: DragState
resetDragState = 
  { index: Nothing, originalX: 0, originalY: 0, currentX: 0, currentY: 0, isDragging: false }

-- conceptual to get my idea across: will not directly compile without proper imports and adjustments
getElementSizeAndPosition :: String -> Effect (Maybe DOMRect)
getElementSizeAndPosition elementId = do
  document <- HA.selectElement
  maybeElement <- getElementById elementId document
  case maybeElement of
    Just element -> do
      rect <- getBoundingClientRect element
      pure $ Just rect
    Nothing -> pure Nothing

I get the following (totally expected) error:

[1 of 1] Compiling Main
Error found:
in module Main
at src/Main.purs:118:86 - 118:91 (line 118, column 86 - line 118, column 91)

  Could not match type

    Event

  with type

    MouseEvent


while checking that type Event
  is at least as general as type MouseEvent
while checking that expression event
  has type MouseEvent
in value declaration renderRow

Let me know if you have any advice or want to help me get this working. I simply wanted a nice, intuitive, idiomatic Purescript-Halogen way to allow a user to reorder a ranked list by dragging it around then submitting the new reordered list once I get this part working but this is breaking my morale and I am starting to get discouraged and burnt out on something so trivial in the ultimate functionality of my DApp. I figure this can also help our ecosystem if we were to accomplish something as dynamic as is shown in the example while still being totally Purescript.

ps. I also wonder how I can get the size of the table without setting it directly in my code? That seems like another case where I’d need to use some unsafe code as well.

Thanks in advance for any advice anyone wants to offer. Purescript is super hard to work in for a beginner like me, but I am dedicated to learning it and Haskell to create my DApp as elegantly as possible.

1 Like
#2

I’m a bit rusty with Halogen but I can help you get through a few errors!

(Also I should note that just because an operation is impure, that doesn’t necessarily mean that you need to use the FFI or Unsafe.Coerce - Halogen should have plenty of tools for working with mouse events.)

Here’s what I did to get this to compile:

Error 1. Could not match type Event with type MouseEvent

The problem is with this array:

renderRow :: forall m. Int -> String -> String -> Maybe Int -> H.ComponentHTML Action () m
renderRow index name occupation dragging =
  HH.tr
>    [ HP.classes $ ClassName <$> ["draggable-table__row"] <>
>        if Just index == dragging then ["is-dragging"] else []
>    , onMouseDown $ HE.handler MVT.mousedown (\event -> StartDrag index (MEV.clientX event) (MEV.clientY event))
>    , onMouseMove $ HE.handler MVT.mousemove (\event -> MoveDrag (MEV.clientX event) (MEV.clientY event))
>    , onMouseUp $ HE.handler MVT.mouseup (\_ -> EndDrag)
>    , onDragOver $ HE.handler MDE.dragover (\event -> DragOver index (MEV.clientY event))
>    , HP.draggable true
>    ]
     [ renderCell name, renderCell occupation ]

Looking at the type signatures for the events and handler, we have:

onMouseDown :: forall r i. (MouseEvent -> i) -> IProp (onMouseDown :: MouseEvent | r) i
handler :: forall r i. EventType -> (Event -> i) -> IProp r i

They both return an IProp, but onMouseDown is more specific. Based on the source of Halogen.HTML.Events, it looks like handler is a helper function for defining other events:

onMouseDown :: forall r i. (MouseEvent -> i) -> IProp (onMouseDown :: MouseEvent | r) i
onMouseDown = handler MET.mousedown <<< mouseHandler

So you can remove the references to handler from the array, leaving us with:

    [ HP.classes $ ClassName <$> ["draggable-table__row"] <>
        if Just index == dragging then ["is-dragging"] else []
    , onMouseDown (\event -> StartDrag index (MEV.clientX event) (MEV.clientY event))
    , onMouseMove (\event -> MoveDrag (MEV.clientX event) (MEV.clientY event))
    , onMouseUp (\_ -> EndDrag)
    , onDragOver (\event -> DragOver index (MEV.clientY event))
    , HP.draggable true
    ]

2. Could not match type Action with type Int -> Action

The error highlights the onMouseMove line of the same array:

     , onMouseDown (\event -> StartDrag index (MEV.clientX event) (MEV.clientY event))
>    , onMouseMove (\event -> MoveDrag (MEV.clientX event) (MEV.clientY event))

But I think the problem is with the onMouseDown line. In the Action type, StartDrag is defined as StartDrag Int Int Int Int, but the onMouseDown handler only gives it three arguments, so the compiler expects onMouseMove to return an Int -> Action as well - instead of a complete Action.

I’ll change StartDrag to Int Int Int because later in handleAction you only use three arguments:

  case action of
    StartDrag index x y ->

3. Could not match type DragEvent with type MouseEvent

On this line of the array:

    , onDragOver (\event -> DragOver index (MEV.clientY event))

I’m kind of stumped by this one. MEV.clientY isn’t working because the argument to onDragOver is a DragEvent, but I can’t find an equivalent of Web.UIEvent.MouseEvent for DragEvents. For the sake of getting this example to compile, I just deleted this line. I’ll come back to it later!

4. Could not match type Aff (Maybe HTMLElement) with type NonElementParentNode

renderRow is good now! The next error is here:

getElementSizeAndPosition :: String -> Effect (Maybe DOMRect)
getElementSizeAndPosition elementId = do
  document <- HA.selectElement
  maybeElement <- getElementById elementId document
                                           ^^^^^^^^

I don’t recommend selectElement here for a couple reasons, but mostly because it uses Aff, and staying in Effect will keep things much simpler.

To make this function work we’ll add these imports:

import Web.HTML (window)
import Web.HTML.HTMLDocument (toNonElementParentNode)
import Web.HTML.Window (toEventTarget, document)

and change the first two lines of getElementSizeAndPosition to these:

  doc <- document =<< window
  maybeElement <- getElementById elementId $ toNonElementParentNode doc

5. Data constructor Main.DragOver was given 1 arguments in a case expression, but expected 2 arguments.

In handleAction:

  case action of
    StartDrag index x y ->
      H.modify_ \s -> s { dragState = { index: Just index, originalX: x, originalY: y, currentX: x, currentY: y, isDragging: true }}
    MoveDrag x y ->
      H.modify_ \s -> s { dragState = s.dragState { currentX = x, currentY = y }}
    DragOver mouseY -> 
    ^^^^^^^^^^^^^^^
      H.modify_ \s -> s { dragOverIndex = findDropIndex mouseY }

Modifying Action to change DragOver Int Int to DragOver Int fixes this.

Compiled!

No more errors after that - you’re free to keep going with this example! Here’s the complete code with all changes:

import Prelude
import Web.DOM

import Data.Array (deleteAt, insertAt, mapWithIndex, (!!))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Aff.Class (class MonadAff)
import Halogen (Component, ComponentHTML, HalogenM, defaultEval, mkComponent, mkEval, modify_) as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Events (onDragOver, onMouseDown, onMouseMove, onMouseUp)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Store.Connect (Connected)
import Halogen.Store.Select as Store
import Halogen.VDom.Driver (runUI)
import Web.DOM.Element (Element)
import Web.DOM.Element (getBoundingClientRect, DOMRect)
import Web.DOM.NonElementParentNode (getElementById)
import Web.HTML (window)
import Web.HTML.Common (ClassName(..))
import Web.HTML.HTMLDocument (toNonElementParentNode)
import Web.HTML.Event.DragEvent.EventTypes (dragover)
import Web.HTML.Event.DragEvent.EventTypes as MDE
import Web.HTML.Window (toEventTarget, document)
import Web.UIEvent.MouseEvent as MEV
import Web.UIEvent.MouseEvent.EventTypes (mousedown, mousemove, mouseup)
import Web.UIEvent.MouseEvent.EventTypes as MVT

type Input = Unit

deriveState :: Connected Store Input -> Store
deriveState { context } = context

selectStore :: Store.Selector Store Store
selectStore = Store.selectEq \store -> store

type DragState = 
  { index :: Maybe Int
  , originalX :: Int
  , originalY :: Int
  , currentX :: Int
  , currentY :: Int
  , isDragging :: Boolean
  }

type Store = 
  { rows :: Array (Tuple String String)
  , dragState :: DragState
  , dragOverIndex :: Maybe Int
  }

data Action
  = StartDrag Int Int Int
  | MoveDrag Int Int
  | DragOver Int
  | EndDrag
  | NoOp

initialStore :: Store
initialStore =  
  { rows: [ Tuple "April Douglas" "Health Educator"
          , Tuple "Salma Mcbride" "Mental Health Counselor"
          , Tuple "Kassandra Donovan" "Makeup Artists"
          , Tuple "Yosef Hartman" "Theatrical and Performance"
          , Tuple "Ronald Mayo" "Plant Etiologist"
          , Tuple "Trey Woolley" "Maxillofacial Surgeon"
          ]
  , dragState: { index: Nothing, originalX: 0, originalY: 0, currentX: 0, currentY: 0, isDragging: false }
  , dragOverIndex: Nothing
  }

component :: forall q m. MonadAff m => H.Component q Unit Void m
component = 
  H.mkComponent
    { initialState
    , render
    , eval: H.mkEval H.defaultEval
        { handleAction = handleAction
        , handleQuery = \_ -> pure Nothing
        , receive = const Nothing
        , initialize = Nothing
        , finalize = Nothing
        }
    }

initialState :: Input -> Store
initialState _ = initialStore

rowHeight :: Int
rowHeight = 50

findDropIndex :: Int -> Maybe Int
findDropIndex currentY =
  let
    rowIndex = currentY `div` rowHeight
  in
    Just rowIndex

render :: forall m. MonadAff m => Store -> H.ComponentHTML Action () m
render state =
  HH.div []
    [ HH.table
        [ HP.class_ (HH.ClassName "draggable-table") ]
        [ HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Name" ], HH.th_ [ HH.text "Occupation" ]]]
        , HH.tbody_ $ mapWithIndex (\index (Tuple name occupation) -> renderRow index name occupation state.dragState.index) state.rows
        ]
    ]

renderRow :: forall m. Int -> String -> String -> Maybe Int -> H.ComponentHTML Action () m
renderRow index name occupation dragging =
  HH.tr
    [ HP.classes $ ClassName <$> ["draggable-table__row"] <>
        if Just index == dragging then ["is-dragging"] else []
    , onMouseDown (\event -> StartDrag index (MEV.clientX event) (MEV.clientY event))
    , onMouseMove (\event -> MoveDrag (MEV.clientX event) (MEV.clientY event))
    , onMouseUp (\_ -> EndDrag)
    -- , onDragOver (\event -> DragOver (MEV.clientY event))
    , HP.draggable true
    ]
    [ renderCell name, renderCell occupation ]

renderCell :: forall m. String -> H.ComponentHTML Action () m
renderCell content =
  HH.td 
    [ HP.class_ (HH.ClassName "table-cell") ]
    [ HH.text content ]

handleAction :: forall m. MonadAff m => Action -> H.HalogenM Store Action () Void m Unit
handleAction action =
  case action of
    StartDrag index x y ->
      H.modify_ \s -> s { dragState = { index: Just index, originalX: x, originalY: y, currentX: x, currentY: y, isDragging: true }}
    MoveDrag x y ->
      H.modify_ \s -> s { dragState = s.dragState { currentX = x, currentY = y }}
    DragOver mouseY -> 
      H.modify_ \s -> s { dragOverIndex = findDropIndex mouseY }
    EndDrag ->
      H.modify_ \s -> case s.dragState.index of
        Just fromIndex -> case s.dragOverIndex of
          Just toIndex -> s { rows = moveRow fromIndex toIndex s.rows
                            , dragState = resetDragState
                            , dragOverIndex = Nothing }
          Nothing -> s { dragState = resetDragState, dragOverIndex = Nothing }
        Nothing -> s
    NoOp -> pure unit

main :: Effect Unit
main = HA.runHalogenAff do
  body <- HA.awaitBody
  runUI component unit body 

moveRow :: Int -> Int -> Array (Tuple String String) -> Array (Tuple String String)
moveRow from to rows =
  let
    draggedRow = fromMaybe (Tuple "" "") $ rows !! from
    rowsWithoutDragged = fromMaybe rows $ deleteAt from rows
  in
    fromMaybe rowsWithoutDragged $ insertAt to draggedRow rowsWithoutDragged

resetDragState :: DragState
resetDragState = 
  { index: Nothing, originalX: 0, originalY: 0, currentX: 0, currentY: 0, isDragging: false }

-- conceptual to get my idea across: will not directly compile without proper imports and adjustments
getElementSizeAndPosition :: String -> Effect (Maybe DOMRect)
getElementSizeAndPosition elementId = do
  doc <- document =<< window
  maybeElement <- getElementById elementId $ toNonElementParentNode doc
  case maybeElement of
    Just element -> do
      rect <- getBoundingClientRect element
      pure $ Just rect
    Nothing -> pure Nothing
2 Likes
#3

Two more things!

First, I think you’re doing very well as a beginner! I know the language throws a lot of things at you all at once when you first start out, but your code was easy to read and debug. While there will always be more to learn, I think you’ll start getting more comfortable with PureScript very quickly.

Second, following up on DragEvents:

I was surprised that purescript-web-uievents doesn’t include a module for DragEvent, but I can kind of understand why: the library says it’s based on the W3C UI Events specification, which doesn’t include DragEvent – that’s actually part of the WHATWG HTML Living Standard (6.11.4).

I said that you shouldn’t have to use Unsafe.Coerce or the FFI, and I stand by that in general, but because this appears to be an edge case you have a choice to make:

  1. Avoid DragEvents entirely by making the DragOver behavior part of the onMouseMove handler instead. It should be possible to get the positions of the table rows and compare them to the current mouse position.

  2. Use the FFI to create functions for working with DragEvents.

    You can use Web.UIEvent.MouseEvent.purs and Web.UIEvent.MouseEvent.js as inspiration. For example, to write the clientY function to make the onDragOver handler work, you would create a YourModule.js file containing:

    export function clientY(e) {
  return e.clientY;
}

    and add this line to YourModule.purs:

    foreign import clientY :: DragEvent -> Int

    Then the handler would look like this:

    , onDragOver (\event -> DragOver (clientY event))

  3. Use Unsafe.Coerce to treat DragEvents as MouseEvents.

    Because DragEvent inherits from MouseEvent, it should be safe to treat a DragEvent like a MouseEvent as long as you only need properties that come from MouseEvent. You can reduce the risk of misusing Unsafe.Coerce by using it to create a new function with specific input and output types. Again using Web.UIEvent.MouseEvent.purs as inspiration, this could look like:

    import Web.HTML.Event.DragEvent (DragEvent)

toMouseEvent :: DragEvent -> MEV.MouseEvent
toMouseEvent = unsafeCoerce

    And then your handler would look like this:

    , onDragOver (\event -> DragOver (MEV.clientY $ toMouseEvent event))

3 Likes
#4

Wow! Thank you so much! I’ll check back as I iterate through this. Thanks for your kind words, extremely generous advice, and attention!

2 Likes