test: router

assets/elm/CommonTypes.elm

@@ -44,13 +44,14 @@ type Routes
     = FaqRoute
     | MainRoute
     | SelectChordRoute
+    | NotARoute
 
 
 type alias Selectors =
     { milisSinceKeyDown : KbdEvent.Key -> Int
     , timeInMillis : () -> Int
     , screenWidth : () -> Int
-    , currentRoute : () -> Maybe Routes
+    , currentRoute : () -> Routes
     }
 
 

assets/elm/Main.elm

@@ -147,7 +147,7 @@ bindSelectors model =
     { milisSinceKeyDown = \key -> OS.milisSinceKeyDown key model.os
     , timeInMillis = \() -> model.os.timeInMillis
     , screenWidth = \() -> model.os.screenWidth
-    , currentRoute = \() -> model.router.currentRoute
+    , currentRoute = \() -> Router.currentRoute model.router
     }
 
 
@@ -156,19 +156,19 @@ update msg model =
     -- Translate route/message combinations into new messages for sub module updates
     let
         mappedMsgs =
-            case ( model.router.currentRoute, msg ) of
-                -- Ignore messages originating from this client
+            case ( Router.currentRoute model.router, msg ) of
+                -- Ignore messages sent to self
                 ( _, Message.ReceivePortMessage clientId _ ) ->
                     if clientId == model.os.clientId then
                         []
 
                     else
                         [ msg ]
 
-                ( Just MainRoute, Message.KeyDown event ) ->
+                ( MainRoute, Message.KeyDown event ) ->
                     case event.key of
                         KbdEvent.KeyEnter ->
-                            case Url.fromString (model.os.baseHref ++ "/selectchord") of
+                            case Url.fromString (Debug.log "requesting" (model.os.baseHref ++ "/selectchord")) of
                                 Just url ->
                                     [ msg, Message.UrlRequest (Browser.Internal url) ]
 
@@ -178,7 +178,7 @@ update msg model =
                         _ ->
                             [ msg ]
 
-                ( Just MainRoute, Message.KeyUp event ) ->
+                ( MainRoute, Message.KeyUp event ) ->
                     let
                         milisSinceKeyDown =
                             OS.milisSinceKeyDown event.key model.os
@@ -204,7 +204,7 @@ update msg model =
                                 (User.Interface.voiceIndexForKey event.key)
                                 |> Maybe.withDefault [ msg ]
 
-                ( Just SelectChordRoute, Message.KeyDown event ) ->
+                ( SelectChordRoute, Message.KeyDown event ) ->
                     let
                         userAction =
                             userActionForKey event.key
@@ -446,8 +446,8 @@ mapUIInstrument update_ msg taggedModel selectors =
 subscriptions : Model -> Sub Message
 subscriptions model =
     Sub.batch
-        [ Browser.Events.onAnimationFrame Message.AnimationFrame
-        , Browser.Events.onResize (\w _ -> Message.WindowResize w)
+        -- [ Browser.Events.onAnimationFrame Message.AnimationFrame
+        [ Browser.Events.onResize (\w _ -> Message.WindowResize w)
         , Browser.Events.onVisibilityChange Message.VisibilityChange
         , Browser.Events.onKeyDown (KbdEvent.decode |> D.map Message.KeyDown)
         , Browser.Events.onKeyUp (KbdEvent.decode |> D.map Message.KeyUp)
@@ -469,43 +469,39 @@ view model =
 body : Model -> List (Html.Html Message.Message)
 body model =
     let
-        maybeCurrentRoute =
-            model.router.currentRoute
+        currentRoute =
+            Router.currentRoute model.router
 
         fallbackHtml =
             Html.p [] [ Html.text model.os.errorMessage ]
     in
     [ UIs.navMenu
-    , Maybe.Extra.unwrap fallbackHtml
-        (\currentRoute ->
-            if List.member currentRoute [ MainRoute, SelectChordRoute ] then
-                Maybe.Extra.unwrap fallbackHtml
-                    (\instrument ->
-                        let
-                            instrumentHtml =
-                                UIs.instrument instrument model.os Message.MouseOverVoice
-
-                            selectChordLink =
-                                Html.a [ Html.Attributes.href "/lab/selectchord" ] [ Html.text "[change]" ]
-
-                            currentChord =
-                                Html.span [] [ Html.text ("chord: " ++ Chord.nameToStr model.uiInstrument.activeChordName) ]
-
-                            defaultHtml =
-                                [ instrumentHtml, currentChord, selectChordLink ]
-                        in
-                        Html.div []
-                            (if currentRoute == SelectChordRoute then
-                                defaultHtml ++ [ viewSelectChord model.uiInstrument ]
-
-                             else
-                                defaultHtml
-                            )
+    , if List.member currentRoute [ MainRoute, SelectChordRoute ] then
+        Maybe.Extra.unwrap fallbackHtml
+            (\instrument ->
+                let
+                    instrumentHtml =
+                        UIs.instrument instrument model.os Message.MouseOverVoice
+
+                    selectChordLink =
+                        Html.a [ Html.Attributes.href "/lab/selectchord" ] [ Html.text "[change]" ]
+
+                    currentChord =
+                        Html.span [] [ Html.text ("chord: " ++ Chord.nameToStr model.uiInstrument.activeChordName) ]
+
+                    defaultHtml =
+                        [ instrumentHtml, currentChord, selectChordLink ]
+                in
+                Html.div []
+                    (if currentRoute == SelectChordRoute then
+                        defaultHtml ++ [ viewSelectChord model.uiInstrument ]
+
+                     else
+                        defaultHtml
                     )
-                    model.instrument
+            )
+            model.instrument
 
-            else
-                fallbackHtml
-        )
-        maybeCurrentRoute
+      else
+        fallbackHtml
     ]

assets/elm/Router.elm

@@ -1,4 +1,4 @@
-module Router exposing (Model, init, update)
+module Router exposing (Model, NavCmd(..), NavKey(..), currentRoute, init, update, update_)
 
 import Browser
 import Browser.Navigation
@@ -7,13 +7,23 @@ import List.Extra
 import Message exposing (Message)
 import Url exposing (Url)
 import Url.Parser exposing ((</>), map, oneOf, s)
-import Utils
+
+
+type NavKey
+    = ActualNavKey Browser.Navigation.Key
+    | TestNavKey
+
+
+type NavCmd
+    = PushUrl NavKey String
+    | GoBack NavKey Int
+    | Load String
+    | NoCmd
 
 
 type alias Model =
-    { currentRoute : Maybe Routes
-    , key : Browser.Navigation.Key
-    , history : List Url
+    { key : NavKey
+    , history : List Routes
     }
 
 
@@ -29,21 +39,21 @@ routeParser =
         ]
 
 
-urlToRoute : Url -> Maybe Routes
+urlToRoute : Url -> Routes
 urlToRoute url =
     Url.Parser.parse routeParser url
+        |> Maybe.withDefault NotARoute
 
 
 init : Url -> Browser.Navigation.Key -> Model
 init url key =
-    { currentRoute = Debug.log "init route" (urlToRoute url)
-    , key = key
-    , history = [ url ]
+    { key = ActualNavKey key
+    , history = [ urlToRoute url ]
     }
 
 
-update : Message -> Model -> Selectors -> ( Model, Cmd Message )
-update msg model _ =
+update_ : Message -> Model -> ( Model, NavCmd )
+update_ msg model =
     case msg of
         Message.UrlRequest req ->
             case req of
@@ -53,37 +63,67 @@ update msg model _ =
                             Url.toString url
                     in
                     case urlToRoute url of
-                        Just FaqRoute ->
-                            ( model, Browser.Navigation.load urlString )
+                        FaqRoute ->
+                            ( model, Load urlString )
 
                         _ ->
-                            ( { model | history = List.append model.history [ url ], currentRoute = urlToRoute url }
-                            , Browser.Navigation.pushUrl model.key urlString
+                            ( model
+                            , PushUrl model.key urlString
                             )
 
                 Browser.External href ->
                     ( model
-                    , Browser.Navigation.load href
+                    , Load href
                     )
 
         Message.UrlChange url ->
-            ( { model | currentRoute = urlToRoute url }, Cmd.none )
+            ( { model | history = List.append model.history [ urlToRoute url ] }, NoCmd )
 
         Message.RequestPreviousUrl n ->
             let
                 newHistory =
                     pop n model.history
-            in
-            case List.Extra.last newHistory of
-                Just previousUrl ->
-                    -- will this trigger a UrlChange message? if not, need to update the model here
-                    ( { model | currentRoute = urlToRoute previousUrl, history = newHistory }, Browser.Navigation.back model.key n )
 
-                Nothing ->
-                    ( model, Cmd.none )
+                cmd =
+                    if List.length model.history >= n then
+                        GoBack model.key n
+
+                    else
+                        NoCmd
+            in
+            ( { model | history = newHistory }, cmd )
 
         _ ->
-            ( model, Cmd.none )
+            ( model, NoCmd )
+
+
+update : Message -> Model -> Selectors -> ( Model, Cmd Message )
+update msg model _ =
+    let
+        ( newModel, cmdWrapper ) =
+            update_ msg model
+
+        cmd =
+            case cmdWrapper of
+                PushUrl (ActualNavKey key) urlString ->
+                    Browser.Navigation.pushUrl key urlString
+
+                GoBack (ActualNavKey key) n ->
+                    Browser.Navigation.back key n
+
+                Load urlString ->
+                    Browser.Navigation.load urlString
+
+                _ ->
+                    Cmd.none
+    in
+    ( newModel, cmd )
+
+
+currentRoute : Model -> Routes
+currentRoute model =
+    List.Extra.last (Debug.log "history" model.history)
+        |> Maybe.withDefault NotARoute
 
 
 pop : Int -> List a -> List a

assets/tests/MessageTests.elm

@@ -0,0 +1,13 @@
+module MessageTests exposing (..)
+
+import Expect
+import Message
+import Test exposing (..)
+
+
+suite : Test
+suite =
+    describe "Message"
+        []
+
+-- testInterpretUserAction: Test