diff --git a/assets/elm/CommonTypes.elm b/assets/elm/CommonTypes.elm index 2405eb1..66defbe 100644 --- a/assets/elm/CommonTypes.elm +++ b/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 } diff --git a/assets/elm/Main.elm b/assets/elm/Main.elm index 3fd7a23..c8b0c1d 100644 --- a/assets/elm/Main.elm +++ b/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,8 +156,8 @@ 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 [] @@ -165,10 +165,10 @@ update msg model = 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 ] diff --git a/assets/elm/Router.elm b/assets/elm/Router.elm index d4dda29..c304217 100644 --- a/assets/elm/Router.elm +++ b/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 diff --git a/assets/tests/MessageTests.elm b/assets/tests/MessageTests.elm new file mode 100644 index 0000000..18afaca --- /dev/null +++ b/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 diff --git a/assets/tests/RouterTests.elm b/assets/tests/RouterTests.elm new file mode 100644 index 0000000..35c8c56 --- /dev/null +++ b/assets/tests/RouterTests.elm @@ -0,0 +1,113 @@ +module RouterTests exposing (..) + +import Browser +import CommonTypes exposing (Routes(..)) +import Expect +import Message +import Router +import Test exposing (..) +import Url + + +suite : Test +suite = + describe "Router" + [ testUpdate ] + + +model : Router.Model +model = + { key = Router.TestNavKey + , history = [] + } + + +exampleUrlStringA : String +exampleUrlStringA = + "http://example.com/lab/fretboard" + + +exampleUrlA : Maybe Url.Url +exampleUrlA = + Url.fromString exampleUrlStringA + + +exampleUrlB : Maybe Url.Url +exampleUrlB = + Url.fromString "http://example.com/lab/selectchord" + + +testUpdate : Test +testUpdate = + case exampleUrlA of + Just url -> + describe "update" + [ describe "UrlRequest" + ((\() -> + let + ( newModel, cmd ) = + Router.update_ (Message.UrlRequest (Browser.Internal url)) model + in + [ test "model" <| + \_ -> + Expect.equal model newModel + , test "command" <| + \_ -> + Expect.equal cmd (Router.PushUrl Router.TestNavKey exampleUrlStringA) + ] + ) + () + ) + , describe "UrlChange" + ((\() -> + let + ( newModel, cmd ) = + Router.update_ (Message.UrlChange url) model + in + [ test "model" <| + \_ -> + Expect.equal { model | history = [ MainRoute ] } newModel + , test "command" <| + \_ -> + Expect.equal cmd Router.NoCmd + ] + ) + () + ) + , describe "RequestPreviousUrl" + ((\() -> + let + ( newModel, cmd ) = + Router.update_ (Message.RequestPreviousUrl 1) model + in + [ test "model" <| + \_ -> + Expect.equal model newModel + , test "command" <| + \_ -> + Expect.equal cmd Router.NoCmd + ] + ) + () + ) + , describe "RequestPreviousUrl when there's history" + ((\() -> + let + newModel = { model | history = [ MainRoute, MainRoute ] } + ( newerModel, cmd ) = + Router.update_ (Message.RequestPreviousUrl 2) newModel + in + [ test "model" <| + \_ -> + Expect.equal model newerModel + , test "command" <| + \_ -> + Expect.equal cmd (Router.GoBack Router.TestNavKey 2) + ] + ) + () + ) + ] + + Nothing -> + test "" <| \_ -> Expect.fail "exampleUrlA isn't a url"