Elm Drag & Drop

The most interesting part is about how the dragging state is represented. It’s simply whether something is being dragged, or nothing.

  
    type State
      = Dragging Element (Float, Float) -- x and y position
      | DoingNothing
  

Compare to this other possible representation:

  
    type MouseState
      = Up
      | Down

    type alias State =
      { mouseState : MouseState
      , mousePos : (Float, Float)
      , draggingElement : Maybe Element
      , receivingElement : Maybe Element
      }
  

With the first union type, the representation is a lot simpler and impossible states are impossible.

Demo

Source code

  
    import Browser
    import Browser.Events as Events
    import Browser.Dom exposing (Element, getElement)
    import Json.Decode as Decode exposing (Decoder)
    import Html exposing (Html, div, ul, li, span, text)
    import Html.Attributes exposing (style)
    -- mpizenberg/elm-pointer-events
    import Html.Events.Extra.Mouse as Mouse
    import Task


    type alias Dropbox =
      { id : String
      , content : Maybe String
      }

    type State
      = Dragging String (Float, Float) -- x and y position
      | DoingNothing

    {-| Set the value of a dropbox
    and reset the value of the other dropboxes
    -}
    setValue : String -> String -> List Dropbox -> List Dropbox
    setValue id value ds =
      List.map (\d ->
        if d.id == id then
          { d | content = Just value }
        else
          { d | content = Nothing }
      ) ds

    displayDropbox : Dropbox -> Html Msg
    displayDropbox dropbox =
      let
        css =
          [ style "display" "inline"
          , style "border-style" "solid"
          , style "border-width" "1px"
          , style "padding" "4px"
          , style "margin-right" "10px"
          , style "vertical-align" "middle"
          ]
      in
        case dropbox.content of
          Just string ->
            div
              ([ Mouse.onDown (\{clientPos} -> Drag string clientPos)
              , style "cursor" "grab"
              ] ++ css)
              [ text string ]
          Nothing ->
            div
              ([ Mouse.onUp (\_ -> ReleaseOn (Just dropbox))
              ] ++ css)
              [ text "Drop it!" ]

    displayDrag : Model -> Html Msg
    displayDrag model =
      case model.state of
        Dragging string (x, y) ->
          let
            (width, height) = model.dragging
            newX = String.fromFloat (x - width / 2)
            newY = String.fromFloat (y - height / 2)
          in
            span
              [ Html.Attributes.id "dragging"
              , style "position" "fixed"
              -- make mouse events go through this dragging element
              , style "pointer-events" "none"
              -- this property will not work because
              -- pointer-events is set to none
              , style "cursor" "grabbing"
              , style "top" (newY ++ "px")
              , style "left" (newX ++ "px")
              ]
              [ text string ]
        DoingNothing ->
          span [] []



    -- MAIN


    type Msg
      = Drag String (Float, Float)
      | ReleaseOn (Maybe Dropbox)
      | SetDraggingElement (Result Browser.Dom.Error Element)

    type alias Model =
      { state : State
      , dropboxes : List Dropbox
      -- width and height of the dragging element
      , dragging : (Float, Float)
      }

    init : () -> (Model, Cmd Msg)
    init _ =
      let
        dropboxes =
          [ { id = "d1"
            , content = Just "Drag me"
            }
          , { id = "d2"
            , content = Nothing
            }
          , { id = "d3"
            , content = Nothing
            }
          ]
        model =
          { state = DoingNothing
          , dropboxes = dropboxes
          , dragging = (0, 0)
          }
      in
        (model, Cmd.none)

    main =
      Browser.element
        { init = init
        , view = view
        , update = update
        , subscriptions = subscriptions
        }

    update : Msg -> Model -> (Model, Cmd Msg)
    update msg model =
      case msg of
        Drag string pos ->
          (
            { model | state = Dragging string pos }
            , Task.attempt SetDraggingElement (getElement "dragging")
          )
        ReleaseOn something ->
          case something of
            Just dst ->
              case model.state of
                Dragging string pos ->
                  ({ model
                    | dropboxes = setValue dst.id string model.dropboxes
                    , state = DoingNothing
                  }, Cmd.none)
                DoingNothing ->
                  ({ model | state = DoingNothing }, Cmd.none)
            Nothing ->
              ({ model | state = DoingNothing }, Cmd.none)
        SetDraggingElement res ->
          case res of
            Ok {element} ->
              ({ model | dragging = (element.width, element.height)}, Cmd.none)
            Err e ->
              (model, Cmd.none)

    {-| Only listen to the mouse move event
    when there is a dragging element
    -}
    subscriptions : Model -> Sub Msg
    subscriptions model =
      case model.state of
        Dragging string _ ->
          Sub.batch
            [ Events.onMouseMove (decoder string)
            , Events.onMouseUp (Decode.succeed (ReleaseOn Nothing))
            ]
        DoingNothing ->
          Sub.none

    {-| Set the position of the dragging element
    while the mouse is moving
    -}
    decoder : String -> Decoder Msg
    decoder string =
      Decode.map2 Tuple.pair
        (Decode.field "clientX" Decode.float)
        (Decode.field "clientY" Decode.float)
      |> Decode.andThen (\pos ->
        Decode.succeed (Drag string pos)
      )

    view : Model -> Html Msg
    view model =
      div
        []
        [ displayDrag model
        , div [] (List.map displayDropbox model.dropboxes)
        ]