Reorderable List in Elm

ReorderList.elm

import Html exposing (..)
import Html.App as Html
import Html.Attributes exposing (..)
import Html.Events exposing (..)
import Json.Decode as Json
import Mouse exposing (Position)



main =
  Html.program
    { init = init
    , view = view
    , update = update
    , subscriptions = subscriptions
    }


-- MODEL


type alias Model =
    { drag : Maybe Drag
    , items : (List Item, List Item)
    }


type alias Drag =
    { item : Item
    , pos : Position
    }


type alias Item =
    { index : Int
    , value : Html Msg
    }


init : ( Model, Cmd Msg )
init =
  let list =
    [ Item 0 <| span [] [text "Hello"]
    , Item 1 <| span [] [text "World"]
    , Item 2 <| span [] [text "Foo"]
    , Item 3 <| span [] [text "Bar"]
    , Item 4 <| span [] [text "Baz"]
    ]
  in  ( Model Nothing (list, []), Cmd.none )



-- UPDATE


type Msg
    = DragStart Item Position
    | DragAt Position
    | DragEnd Position
    | Over Int


update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
  ( updateHelp msg model, Cmd.none )


updateHelp : Msg -> Model -> Model
updateHelp msg ({drag, items} as model) =
  let (left, right) = items
  in case msg of
    DragStart ({index} as item) xy ->
      Model (Just (Drag item xy)) (items |> split index)

    DragAt xy ->
      Model (Maybe.map (\{item} -> Drag item xy) drag) items

    DragEnd _ ->
      case drag of
        Nothing -> model
        Just {item} -> Model Nothing (items |> join item |> order)

    Over i ->
      Model drag (items |> partition i)


split : Int -> (List Item, List Item) -> (List Item, List Item)
split i (left, right) =
  left ++ right
    |> List.filter (\{index} -> index /= i)
    |> List.foldr (
       \item (l, r) ->
         if item.index < i
           then (item :: l, r)
           else (l, item :: r) )
       ([], [])


join : Item -> (List Item, List Item) -> (List Item, List Item)
join mid (left, right) =
  ( left ++ (mid :: right), [] )


partition : Int -> (List Item, List Item) -> (List Item, List Item)
partition i (left, right) =
  let
    op =
      case right of
        [] -> (<)
        {index} :: _ ->
          if i < index
            then (<)
            else (<=)
  in
    left ++ right |> List.foldr (
      \item (l, r) ->
        if item.index `op` i
          then (item :: l, r)
          else (l, item :: r) )
      ([], [])


order : (List Item, List Item) -> (List Item, List Item)
order (left, right) =
  case right of
    [] -> ( left |> List.indexedMap (\i item -> { item | index = i }), [] )
    _ -> (left, right)


-- SUBSCRIPTIONS


subscriptions : Model -> Sub Msg
subscriptions model =
  case model.drag of
    Nothing ->
      Sub.none

    Just _ ->
      Sub.batch [ Mouse.moves DragAt, Mouse.ups DragEnd ]



-- VIEW


(=>) = (,)


view : Model -> Html Msg
view {drag, items} =
  let
    (left, right) =
      items

    realPosition =
      case drag of
        Nothing -> Position 0 0
        Just {pos} -> Position (pos.x - 15) (pos.y - 15)

    element floating empty ({index, value} as item) =
      div
        [ style <|
          [ "background-color" => "limegreen"
          , "width" => "200px"
          , "color" => "white"
          , "display" => "flex"
          , "height" => "30px"
          ] ++ if floating then
              [ "box-shadow" => "0 0 10px black"
              , "position" => "absolute"
              , "left" => px realPosition.x
              , "top" => px realPosition.y
              ] else 
              [ "border-bottom" => "1px solid black"
              ]
        ] <|
        if empty then [] else
        [ div
          [ onMouseDown item
          , style
            [ "height" => "100%"
            , "width" => "30px"
            , "display" => "flex"
            , "justify-content" => "center"
            , "align-items" => "center"
            , "cursor" => "move"
            ]
          ]
          [ span [] [text "☰"] ]
        , div
          [ style
            [ "text-align" => "center"
            , "flex" => "1"
            , "display" => "flex"
            , "justify-content" => "center"
            , "align-items" => "center"
            ]
          ]
          [ value ]
        ]

    toElement item =
      case drag of
        Nothing -> element False False item
        Just _ ->
          div [ style ["position" => "relative"] ]
            [ div
              [ onMouseOver (Over item.index)
              , style
                [ "width" => "200px"
                , "height" => "30px"
                , "z-index" => "100"
                , "position" => "absolute"
                , "top" => "0"
                , "left" => "0"
                ]
              ] []
            , element False False item
            ]

    floater =
      case drag of
        Nothing -> []
        Just {item} -> [element True False item]

    empty =
      element False True (Item -1 <| div [] [])

    list =
      (List.map toElement left) ++ (case drag of
        Nothing -> List.map toElement right
        Just _ -> empty :: (List.map toElement right))

  in
    div [ style [] ] (list ++ floater)


px : Int -> String
px number =
  toString number ++ "px"


onMouseDown : Item -> Attribute Msg
onMouseDown item =
  onWithOptions
    "mousedown"
    (Html.Events.Options True True)
    (Json.map (DragStart item) Mouse.position)