TestContext.routeChange works with (some) relative URLs

src/Navigation/Extra.elm

@@ -1,4 +1,4 @@
-module Navigation.Extra exposing (locationFromString)
+module Navigation.Extra exposing (locationFromString, resolve)
 
 {-| TODO: this module should implement the algorithm described at
 <https://url.spec.whatwg.org/>
@@ -14,16 +14,28 @@ NOTE: the behavior of when `Nothing` is returned may change when the correct imp
 -}
 locationFromString : String -> Maybe Navigation.Location
 locationFromString url =
-    Just
-        { hash = "TODO"
-        , host = "TODO"
-        , hostname = "TODO"
-        , href = url
-        , origin = "TODO"
-        , password = "TODO"
-        , pathname = "/" ++ (url |> String.split "/" |> List.drop 3 |> String.join "/")
-        , port_ = "TODO"
-        , protocol = "TODO"
-        , search = "TODO"
-        , username = "TODO"
-        }
+    if String.contains "://" url then
+        Just
+            { hash = "TODO"
+            , host = "TODO"
+            , hostname = "TODO"
+            , href = url
+            , origin = "TODO"
+            , password = "TODO"
+            , pathname = "/" ++ (url |> String.split "/" |> List.drop 3 |> String.join "/")
+            , port_ = "TODO"
+            , protocol = "TODO"
+            , search = "TODO"
+            , username = "TODO"
+            }
+    else
+        Nothing
+
+
+{-| This resolves a URL string (either an absolute or relative URL) against a base URL (given as a `Location`).
+-}
+resolve : Navigation.Location -> String -> Navigation.Location
+resolve base url =
+    locationFromString url
+        -- TODO: implment correct logic (current logic is only correct for "authority-relative" URLs without query or fragment strings)
+        |> Maybe.withDefault { base | pathname = url }

src/TestContext.elm

@@ -4,6 +4,7 @@ module TestContext
         , clickButton
         , create
         , createWithFlags
+        , createWithJsonStringFlags
         , createWithNavigation
         , createWithNavigationAndFlags
         , createWithNavigationAndJsonStringFlags
@@ -12,8 +13,10 @@ module TestContext
         , expectModel
         , expectView
         , expectViewHas
+        , fail
         , routeChange
         , shouldHave
+        , shouldHaveLastEffect
         , shouldHaveView
         , shouldNotHave
         , simulate
@@ -26,7 +29,7 @@ module TestContext
 ## Creating
 
 @docs TestContext
-@docs create, createWithFlags
+@docs create, createWithFlags, createWithJsonStringFlags
 @docs createWithNavigation, createWithNavigationAndFlags, createWithNavigationAndJsonStringFlags
 
 
@@ -43,14 +46,23 @@ module TestContext
 
 ## Final assertions
 
-@docs expectViewHas, expectView, expectLastEffect, expectModel
+@docs expectViewHas, expectView
+@docs expectLastEffect, expectModel
 
 
 ## Intermediate assertions
 
 These functions can be used to make assertions on a `TestContext` without ending the test.
 
 @docs shouldHave, shouldNotHave, shouldHaveView
+@docs shouldHaveLastEffect
+
+
+## Custom assertions
+
+These functions may be useful if you are writing your own custom assertion functions.
+
+@docs fail
 
 -}
 
@@ -68,7 +80,7 @@ import Test.Runner.Failure
 
 
 type TestContext msg model effect
-    = TestContext (Result Failure ( TestProgram msg model effect, ( model, effect ) ))
+    = TestContext (Result Failure ( TestProgram msg model effect, ( model, effect ), Maybe Navigation.Location ))
 
 
 type alias TestProgram msg model effect =
@@ -84,13 +96,16 @@ type Failure
     | SimulateFailedToFindTarget String String
     | InvalidLocationUrl String String
     | InvalidFlags String String
+    | ProgramDoesNotSupportNavigation String
+    | CustomFailure String String
 
 
 createHelper :
     { init : ( model, effect )
     , update : msg -> model -> ( model, effect )
     , view : model -> Html msg
     , onRouteChange : Navigation.Location -> Maybe msg
+    , initialLocation : Maybe Navigation.Location
     }
     -> TestContext msg model effect
 createHelper program =
@@ -101,6 +116,7 @@ createHelper program =
               , onRouteChange = program.onRouteChange
               }
             , program.init
+            , program.initialLocation
             )
 
 
@@ -116,6 +132,7 @@ create program =
         , update = program.update
         , view = program.view
         , onRouteChange = \_ -> Nothing
+        , initialLocation = Nothing
         }
 
 
@@ -132,9 +149,34 @@ createWithFlags program flags =
         , update = program.update
         , view = program.view
         , onRouteChange = \_ -> Nothing
+        , initialLocation = Nothing
         }
 
 
+createWithJsonStringFlags :
+    Json.Decode.Decoder flags
+    ->
+        { init : flags -> ( model, effect )
+        , update : msg -> model -> ( model, effect )
+        , view : model -> Html msg
+        }
+    -> String
+    -> TestContext msg model effect
+createWithJsonStringFlags flagsDecoder program flagsJson =
+    case Json.Decode.decodeString flagsDecoder flagsJson of
+        Err message ->
+            TestContext <| Err (InvalidFlags "createWithJsonStringFlags" message)
+
+        Ok flags ->
+            createHelper
+                { init = program.init flags
+                , update = program.update
+                , view = program.view
+                , onRouteChange = \_ -> Nothing
+                , initialLocation = Nothing
+                }
+
+
 createWithNavigation :
     (Navigation.Location -> msg)
     ->
@@ -155,6 +197,7 @@ createWithNavigation onRouteChange program initialUrl =
                 , update = program.update
                 , view = program.view
                 , onRouteChange = onRouteChange >> Just
+                , initialLocation = Just location
                 }
 
 
@@ -179,6 +222,7 @@ createWithNavigationAndFlags onRouteChange program initialUrl flags =
                 , update = program.update
                 , view = program.view
                 , onRouteChange = onRouteChange >> Just
+                , initialLocation = Just location
                 }
 
 
@@ -209,6 +253,7 @@ createWithNavigationAndJsonStringFlags flagsDecoder onRouteChange program initia
                         , update = program.update
                         , view = program.view
                         , onRouteChange = onRouteChange >> Just
+                        , initialLocation = Just location
                         }
 
 
@@ -219,10 +264,11 @@ update msg (TestContext result) =
             Err err ->
                 Err err
 
-            Ok ( program, ( model, _ ) ) ->
+            Ok ( program, ( model, _ ), currentLocation ) ->
                 Ok
                     ( program
                     , program.update msg model
+                    , currentLocation
                     )
 
 
@@ -232,7 +278,7 @@ simulateHelper functionDescription findTarget event (TestContext result) =
         Err err ->
             TestContext <| Err err
 
-        Ok ( program, ( model, _ ) ) ->
+        Ok ( program, ( model, _ ), _ ) ->
             let
                 targetQuery =
                     program.view model
@@ -281,24 +327,27 @@ clickButton buttonText testContext =
         testContext
 
 
+{-| `url` may be an absolute URL or relative URL
+-}
 routeChange : String -> TestContext msg model effect -> TestContext msg model effect
 routeChange url (TestContext result) =
     case result of
         Err err ->
             TestContext <| Err err
 
-        Ok ( program, model ) ->
-            case Navigation.Extra.locationFromString url of
-                Nothing ->
-                    TestContext <| Err (InvalidLocationUrl "routeChange" url)
+        Ok ( program, _, Nothing ) ->
+            TestContext <| Err (ProgramDoesNotSupportNavigation "routeChange")
 
-                Just location ->
-                    case program.onRouteChange location of
-                        Nothing ->
-                            TestContext result
+        Ok ( program, _, Just currentLocation ) ->
+            case
+                Navigation.Extra.resolve currentLocation url
+                    |> program.onRouteChange
+            of
+                Nothing ->
+                    TestContext result
 
-                        Just msg ->
-                            update msg (TestContext result)
+                Just msg ->
+                    update msg (TestContext result)
 
 
 expectModel : (model -> Expectation) -> TestContext msg model effect -> Expectation
@@ -309,30 +358,41 @@ expectModel assertion (TestContext result) =
                 Err err ->
                     Err err
 
-                Ok ( program, ( model, lastEffect ) ) ->
+                Ok ( _, ( model, _ ), _ ) ->
                     case assertion model |> Test.Runner.getFailureReason of
                         Nothing ->
-                            Ok ( program, ( model, lastEffect ) )
+                            result
 
                         Just reason ->
                             Err (ExpectFailed "expectModel" reason.description reason.reason)
 
 
-expectLastEffect : (effect -> Expectation) -> TestContext msg model effect -> Expectation
-expectLastEffect assertion (TestContext result) =
-    done <|
-        TestContext <|
-            case result of
-                Err err ->
-                    Err err
+expectLastEffectHelper : String -> (effect -> Expectation) -> TestContext msg model effect -> TestContext msg model effect
+expectLastEffectHelper functionName assertion (TestContext result) =
+    TestContext <|
+        case result of
+            Err err ->
+                Err err
 
-                Ok ( program, ( model, lastEffect ) ) ->
-                    case assertion lastEffect |> Test.Runner.getFailureReason of
-                        Nothing ->
-                            Ok ( program, ( model, lastEffect ) )
+            Ok ( _, ( _, lastEffect ), _ ) ->
+                case assertion lastEffect |> Test.Runner.getFailureReason of
+                    Nothing ->
+                        result
 
-                        Just reason ->
-                            Err (ExpectFailed "expectLastEffect" reason.description reason.reason)
+                    Just reason ->
+                        Err (ExpectFailed functionName reason.description reason.reason)
+
+
+shouldHaveLastEffect : (effect -> Expectation) -> TestContext msg model effect -> TestContext msg model effect
+shouldHaveLastEffect assertion testContext =
+    expectLastEffectHelper "shouldHaveLastEffect" assertion testContext
+
+
+expectLastEffect : (effect -> Expectation) -> TestContext msg model effect -> Expectation
+expectLastEffect assertion testContext =
+    testContext
+        |> expectLastEffectHelper "expectLastEffect" assertion
+        |> done
 
 
 expectViewHelper : String -> (Query.Single msg -> Expectation) -> TestContext msg model effect -> TestContext msg model effect
@@ -342,7 +402,7 @@ expectViewHelper functionName assertion (TestContext result) =
             Err err ->
                 Err err
 
-            Ok ( program, ( model, lastEffect ) ) ->
+            Ok ( program, ( model, _ ), _ ) ->
                 case
                     model
                         |> program.view
@@ -351,7 +411,7 @@ expectViewHelper functionName assertion (TestContext result) =
                         |> Test.Runner.getFailureReason
                 of
                     Nothing ->
-                        Ok ( program, ( model, lastEffect ) )
+                        result
 
                     Just reason ->
                         Err (ExpectFailed functionName reason.description reason.reason)
@@ -406,3 +466,39 @@ done (TestContext result) =
 
         Err (InvalidFlags functionName message) ->
             Expect.fail (functionName ++ ":\n" ++ message)
+
+        Err (ProgramDoesNotSupportNavigation functionName) ->
+            Expect.fail (functionName ++ ": Program does not support navigation.  Use TestContext.createWithNavigation or related function to create a TestContext that supports navigation.")
+
+        Err (CustomFailure assertionName message) ->
+            Expect.fail (assertionName ++ ": " ++ message)
+
+
+{-| `fail` can be used to report custom errors if you are writing your own convenience functions to deal with test contexts.
+
+Example (this is a function that checks for a particular structure in the program's view,
+but will also fail the TestContext if the `expectedCount` parameter is invalid):
+
+    expectNotificationCount : Int -> TestContext Msg Model effect -> TestContext Msg Model effect
+    expectNotificationCount expectedCount testContext =
+        if expectedCount <= 0 then
+            testContext
+                |> TestContext.fail "expectNotificationCount"
+                    ("expectedCount must be positive, but was: " ++ toString expectedCount)
+        else
+            testContext
+                |> shouldHave
+                    [ Test.Html.Selector.class "notifications"
+                    , Test.Html.Selector.text (toString expectedCount)
+                    ]
+
+-}
+fail : String -> String -> TestContext msg model effect -> TestContext msg model effect
+fail assertionName failureMessage (TestContext result) =
+    TestContext <|
+        case result of
+            Err err ->
+                Err err
+
+            Ok _ ->
+                Err (CustomFailure assertionName failureMessage)