Draggable table

DragTable.elm

module DragTable exposing (..)

import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
import Json.Decode as Json exposing (Decoder, Value)
import Dict exposing (Dict)
import List as L exposing (drop, take)
import Tuple


type Column
    = Firstname
    | Surname
    | House


type alias Model =
    { data : MyData
    , rows : List Int
    , cols : List Column
    , draggedRow : Maybe Int
    , hoveredRow : Maybe Int
    , newRows : Maybe (List Int)
    , draggedCol : Maybe Int
    , hoveredCol : Maybe Int
    , newCols : Maybe (List Column)
    }


type alias MyData =
    Dict ( Int, String ) String


init : List (List String) -> Model
init rawData =
    Model (importData rawData) (L.range 0 <| L.length rawData - 1) columns Nothing Nothing Nothing Nothing Nothing Nothing


type Msg
    = DragRowStart Int Json.Value
    | DragRowEnter Int Json.Value
    | DragRowEnd Int Json.Value
    | DragColStart Int Json.Value
    | DragColEnter Int Json.Value
    | DragColEnd Int Json.Value
    | SwapColumns


update : Msg -> Model -> Model
update message model =
    case message of
        DragRowStart draggedRow _ ->
            { model | draggedRow = Just draggedRow }

        DragRowEnter hoveredRow _ ->
            case model.draggedRow of
                Nothing ->
                    model

                Just draggedRow ->
                    { model
                        | hoveredRow =
                            Just hoveredRow
                        , newRows = Just <| dropper draggedRow hoveredRow model.rows
                    }

        DragRowEnd draggedRow _ ->
            case ( model.draggedRow, model.hoveredRow ) of
                ( Just d, Just h ) ->
                    { model
                        | draggedRow = Nothing
                        , hoveredRow = Nothing
                        , rows = dropper d h model.rows
                        , newRows = Nothing
                    }

                _ ->
                    { model
                        | draggedRow = Nothing
                        , hoveredRow = Nothing
                        , newRows = Nothing
                    }

        DragColStart draggedCol _ ->
            { model | draggedCol = Just draggedCol }

        DragColEnter hoveredCol _ ->
            case model.draggedCol of
                Nothing ->
                    model

                Just draggedCol ->
                    { model
                        | hoveredCol =
                            Just hoveredCol
                        , newCols = Just <| dropper draggedCol hoveredCol model.cols
                    }

        DragColEnd draggedCol _ ->
            case ( model.draggedCol, model.hoveredCol ) of
                ( Just d, Just h ) ->
                    { model
                        | draggedCol = Nothing
                        , hoveredCol = Nothing
                        , cols = dropper d h model.cols
                        , newCols = Nothing
                    }

                _ ->
                    { model
                        | draggedCol = Nothing
                        , hoveredCol = Nothing
                        , newCols = Nothing
                    }

        SwapColumns ->
            { model | cols = [ House, Firstname, Surname ] }


view : Model -> Html Msg
view model =
    div
        [ mainStyles ]
        [ model.newCols
            |> Maybe.withDefault model.cols
            |> viewHeader
        , model.newRows
            |> Maybe.withDefault model.rows
            |> L.indexedMap (viewRow model)
            |> div []
        ]



--


viewHeader : List Column -> Html Msg
viewHeader columns =
    columns
        |> L.indexedMap makeHeaderCell
        |> div [ rowStyles "steelblue" ]


makeHeaderCell : Int -> Column -> Html Msg
makeHeaderCell idx col =
    div (headerColumnAttributes idx) [ dragger, text <| toString col ]


headerColumnAttributes idx =
    [ draggable "true"
    , onDragStart (DragColStart idx)
    , onDragEnter (DragColEnter idx)
    , onDragEnd (DragColEnd idx)
    , cellStyles
    ]



--


viewRow : Model -> Int -> Int -> Html Msg
viewRow model idx v =
    model.newCols
        |> Maybe.withDefault model.cols
        |> L.map (viewElement model v)
        |> (::) dragger
        |> div (rowAttributes idx model)


dragger =
    span [ draggerStyle ] [ text "☰" ]


rowAttributes : Int -> Model -> List (Html.Attribute Msg)
rowAttributes idx model =
    [ rowStyles "#eee"
    , draggable "true"
    , onDragStart (DragRowStart idx)
    , onDragEnter (DragRowEnter idx)
    , onDragEnd (DragRowEnd idx)
    ]


viewElement : Model -> Int -> Column -> Html msg
viewElement model idx col =
    Dict.get ( idx, toString col ) model.data
        |> Maybe.map makeCell
        |> Maybe.withDefault (text "error")


makeCell d =
    div [ cellStyles ] [ text d ]



--


mainStyles =
    style
        [ ( "padding", "20px" )
        , ( "user-select", "none" )
        ]


rowStyles backgroundColour =
    style
        [ ( "border-bottom", "1px solid #555" )
        , ( "height", "50px" )
        , ( "overflow-y", "hidden" )
        , ( "background-color", backgroundColour )
        , ( "align-items", "center" )
        , ( "display", "flex" )
        , ( "padding-left", "15px" )
        ]


cellStyles =
    style
        [ ( "padding", "5px" )
        , ( "width", "150px" )
        , ( "display", "inline-block" )
        ]


draggerStyle =
    style
        [ ( "cursor", "move" ) ]



-- ===========================================


onDragStart msgCreator =
    on "dragstart" (Json.map msgCreator dec)


onDragEnter msgCreator =
    on "dragenter" (Json.map msgCreator dec)


onDragEnd : (Json.Value -> Msg) -> Attribute Msg
onDragEnd msgCreator =
    on "dragend" (Json.map msgCreator dec)


dec : Decoder Value
dec =
    Json.field "target" Json.value



-- =============================================


dropper : Int -> Int -> List a -> List a
dropper dragged hovered lst =
    case compare dragged hovered of
        EQ ->
            lst

        LT ->
            case divideIn3 dragged hovered lst of
                ( p1, d :: p2, h :: p3 ) ->
                    p1 ++ p2 ++ (h :: d :: p3)

                _ ->
                    lst

        GT ->
            case divideIn3 hovered dragged lst of
                ( p1, h :: p2, d :: p3 ) ->
                    p1 ++ (d :: h :: p2) ++ p3

                _ ->
                    lst


divideIn3 : Int -> Int -> List a -> ( List a, List a, List a )
divideIn3 low high lst =
    let
        go l ( ( ls, ms, hs ), idx ) =
            if idx >= high then
                ( ( ls, ms, l :: hs ), idx - 1 )
            else if idx >= low then
                ( ( ls, l :: ms, hs ), idx - 1 )
            else
                ( ( l :: ls, ms, hs ), idx - 1 )
    in
        L.foldr go ( ( [], [], [] ), L.length lst - 1 ) lst |> Tuple.first



-- ===========================


main =
    Html.beginnerProgram
        { model = init rawData
        , update = update
        , view = view
        }



-- ===========================


columns =
    [ Firstname, Surname, House ]


rawData : List (List String)
rawData =
    [ [ "Harry", "Potter", "Gryffindor" ]
    , [ "Draco", "Malfoy", "Slytherin" ]
    , [ "Cedric", "Diggory", "Hufflepuff" ]
    , [ "Cho", "Chang", "Ravenclaw" ]
    ]


importData : List (List String) -> MyData
importData =
    L.indexedMap (importRow columns)
        >> L.concat
        >> Dict.fromList


importRow : List Column -> Int -> List String -> List ( ( Int, String ), String )
importRow columns idx row =
    row
        |> zip columns
        |> L.map (\( c, d ) -> ( ( idx, toString c ), d ))


zip xxs yys =
    case ( xxs, yys ) of
        ( x :: xs, y :: ys ) ->
            ( x, y ) :: zip xs ys

        _ ->
            []