Fix #115: Add keyboard navigation to media viewer.

elm-package.json

@@ -16,6 +16,7 @@
         "elm-lang/dom": "1.1.1 <= v < 2.0.0",
         "elm-lang/html": "2.0.0 <= v < 3.0.0",
         "elm-lang/http": "1.0.0 <= v < 2.0.0",
+        "elm-lang/keyboard": "1.0.1 <= v < 2.0.0",
         "elm-lang/navigation": "2.1.0 <= v < 3.0.0",
         "elm-lang/websocket": "1.0.2 <= v < 2.0.0",
         "evancz/url-parser": "2.0.1 <= v < 3.0.0",

src/Subscription.elm

@@ -1,6 +1,7 @@
 module Subscription exposing (subscriptions)
 
 import Autocomplete
+import Keyboard
 import Mastodon.WebSocket
 import Ports
 import Time
@@ -44,6 +45,9 @@ subscriptions { clients, currentView } =
 
         uploadErrorSub =
             Ports.uploadError (DraftEvent << UploadError)
+
+        keyDownsSub =
+            Keyboard.downs KeyMsg
     in
         Sub.batch
             [ timeSub
@@ -52,4 +56,5 @@ subscriptions { clients, currentView } =
             , autoCompleteSub
             , uploadSuccessSub
             , uploadErrorSub
+            , keyDownsSub
             ]

src/Types.elm

@@ -1,6 +1,7 @@
 module Types exposing (..)
 
 import Autocomplete
+import Keyboard
 import Mastodon.Http exposing (Response, Links)
 import Mastodon.Model exposing (..)
 import Navigation
@@ -34,6 +35,8 @@ type DraftMsg
 type ViewerMsg
     = CloseViewer
     | OpenViewer (List Attachment) Attachment
+    | PrevAttachment
+    | NextAttachment
 
 
 type alias MastodonResult a =
@@ -99,6 +102,7 @@ type Msg
     | DraftEvent DraftMsg
     | FilterNotifications NotificationFilter
     | FollowAccount Account
+    | KeyMsg Keyboard.KeyCode
     | LogoutClient Client
     | TimelineLoadNext String String
     | MastodonEvent MastodonMsg

src/Update/Main.elm

@@ -55,6 +55,23 @@ update msg model =
             }
                 ! []
 
+        KeyMsg code ->
+            case ( code, model.viewer ) of
+                ( 27, Just _ ) ->
+                    -- Esc
+                    update (ViewerEvent CloseViewer) model
+
+                ( 37, Just _ ) ->
+                    -- Left arrow
+                    update (ViewerEvent PrevAttachment) model
+
+                ( 39, Just _ ) ->
+                    -- Right arrow
+                    update (ViewerEvent NextAttachment) model
+
+                _ ->
+                    model ! []
+
         ClearError index ->
             { model | errors = removeAt index model.errors } ! []
 

src/Update/Viewer.elm

@@ -1,8 +1,19 @@
-module Update.Viewer exposing (update)
+module Update.Viewer exposing (getPrevNext, update)
 
+import List.Extra exposing (elemIndex, getAt)
+import Mastodon.Model exposing (..)
 import Types exposing (..)
 
 
+getPrevNext : Viewer -> ( Maybe Attachment, Maybe Attachment )
+getPrevNext { attachments, attachment } =
+    let
+        index =
+            Maybe.withDefault -1 <| elemIndex attachment attachments
+    in
+        ( getAt (index - 1) attachments, getAt (index + 1) attachments )
+
+
 update : ViewerMsg -> Maybe Viewer -> ( Maybe Viewer, Cmd Msg )
 update viewerMsg viewer =
     case viewerMsg of
@@ -11,3 +22,29 @@ update viewerMsg viewer =
 
         OpenViewer attachments attachment ->
             (Just <| Viewer attachments attachment) ! []
+
+        PrevAttachment ->
+            case viewer of
+                Just viewer ->
+                    case getPrevNext viewer of
+                        ( Just prev, _ ) ->
+                            (Just <| Viewer viewer.attachments prev) ! []
+
+                        _ ->
+                            Just viewer ! []
+
+                Nothing ->
+                    viewer ! []
+
+        NextAttachment ->
+            case viewer of
+                Just viewer ->
+                    case getPrevNext viewer of
+                        ( _, Just next ) ->
+                            (Just <| Viewer viewer.attachments next) ! []
+
+                        _ ->
+                            Just viewer ! []
+
+                Nothing ->
+                    viewer ! []

src/View/Viewer.elm

@@ -2,21 +2,18 @@ module View.Viewer exposing (viewerView)
 
 import Html exposing (..)
 import Html.Attributes exposing (..)
-import List.Extra exposing (find, elemIndex, getAt)
 import Types exposing (..)
+import Update.Viewer exposing (getPrevNext)
 import View.Events exposing (..)
 
 
 viewerView : Viewer -> Html Msg
-viewerView { attachments, attachment } =
+viewerView ({ attachments, attachment } as viewer) =
     let
-        index =
-            Maybe.withDefault -1 <| elemIndex attachment attachments
-
         ( prev, next ) =
-            ( getAt (index - 1) attachments, getAt (index + 1) attachments )
+            getPrevNext viewer
 
-        navLink label className target =
+        navLink label className target event =
             case target of
                 Nothing ->
                     text ""
@@ -25,8 +22,7 @@ viewerView { attachments, attachment } =
                     a
                         [ href ""
                         , class className
-                        , onClickWithPreventAndStop <|
+                        , onClickWithPreventAndStop event
-                            ViewerEvent (OpenViewer attachments target)
                         ]
                         [ text label ]
     in
@@ -36,7 +32,7 @@ viewerView { attachments, attachment } =
             , onClickWithPreventAndStop <| ViewerEvent CloseViewer
             ]
             [ span [ class "close" ] [ text "×" ]
-            , navLink "❮" "prev" prev
+            , navLink "❮" "prev" prev <| ViewerEvent NextAttachment
             , case attachment.type_ of
                 "image" ->
                     img [ class "viewer-content", src attachment.url ] []
@@ -49,5 +45,5 @@ viewerView { attachments, attachment } =
                         , loop True
                         ]
                         [ source [ src attachment.url ] [] ]
-            , navLink "❯" "next" next
+            , navLink "❯" "next" next <| ViewerEvent NextAttachment
             ]

tests/elm-package.json

@@ -23,6 +23,7 @@
       "elm-lang/dom": "1.1.1 <= v < 2.0.0",
       "elm-lang/html": "2.0.0 <= v < 3.0.0",
       "elm-lang/http": "1.0.0 <= v < 2.0.0",
+      "elm-lang/keyboard": "1.0.1 <= v < 2.0.0",
       "elm-lang/navigation": "2.1.0 <= v < 3.0.0",
       "elm-lang/websocket": "1.0.2 <= v < 2.0.0",
       "evancz/url-parser": "2.0.1 <= v < 3.0.0",