diff --git a/src/MicroListExtra.elm b/src/MicroListExtra.elm index 3a60c9f8..dfb3a331 100644 --- a/src/MicroListExtra.elm +++ b/src/MicroListExtra.elm @@ -6,6 +6,7 @@ module MicroListExtra exposing , setAt , splitWhen , transpose + , unique ) @@ -98,3 +99,26 @@ rowsLength listOfLists = x :: _ -> List.length x + + +unique : List a -> List a +unique list = + uniqueHelp identity [] list [] + + +uniqueHelp : (a -> b) -> List b -> List a -> List a -> List a +uniqueHelp f existing remaining accumulator = + case remaining of + [] -> + List.reverse accumulator + + first :: rest -> + let + computedFirst = + f first + in + if List.member computedFirst existing then + uniqueHelp f existing rest accumulator + + else + uniqueHelp f (computedFirst :: existing) rest (first :: accumulator) diff --git a/src/Test/Html/Internal/ElmHtml/InternalTypes.elm b/src/Test/Html/Internal/ElmHtml/InternalTypes.elm index f2a6bc73..35c80fe6 100644 --- a/src/Test/Html/Internal/ElmHtml/InternalTypes.elm +++ b/src/Test/Html/Internal/ElmHtml/InternalTypes.elm @@ -2,6 +2,7 @@ module Test.Html.Internal.ElmHtml.InternalTypes exposing ( ElmHtml(..), TextTagRecord, NodeRecord, CustomNodeRecord, MarkdownNodeRecord , Facts, Tagger, EventHandler, ElementKind(..) , Attribute(..), AttributeRecord, NamespacedAttributeRecord, PropertyRecord, EventRecord + , Validation(..), validationMessage, validationFromMessage , decodeElmHtml, emptyFacts, toElementKind, decodeAttribute ) @@ -13,6 +14,8 @@ module Test.Html.Internal.ElmHtml.InternalTypes exposing @docs Attribute, AttributeRecord, NamespacedAttributeRecord, PropertyRecord, EventRecord +@docs Validation, validationMessage, validationFromMessage + @docs decodeElmHtml, emptyFacts, toElementKind, decodeAttribute -} @@ -317,16 +320,56 @@ decodeStyles = ] +type Validation + = ClassVsClassNameValidation + + +classVsClassNameValidationMessage : String +classVsClassNameValidationMessage = + "Found the `class` attribute and the `className` property used in the same HTML node. This would result in unspecified behaviour, and elm-test wouldn't be able to reliably query for classnames. Please only use one of the two." + + +validationMessage : Validation -> String +validationMessage validation = + case validation of + ClassVsClassNameValidation -> + classVsClassNameValidationMessage + + +validationFromMessage : String -> Maybe Validation +validationFromMessage message = + if message == classVsClassNameValidationMessage then + Just ClassVsClassNameValidation + + else + Nothing + + {-| grab things from attributes via a decoder, then anything that isn't filtered on the object -} -decodeOthers : Json.Decode.Decoder a -> Json.Decode.Decoder (Dict String a) -decodeOthers otherDecoder = +decodeOthers : Json.Decode.Decoder a -> Maybe Validation -> Json.Decode.Decoder (Dict String a) +decodeOthers otherDecoder validation = decodeAttributes otherDecoder |> Json.Decode.andThen (\attributes -> decodeDictFilterMap otherDecoder |> Json.Decode.map (filterKnownKeys >> Dict.union attributes) + |> (case validation of + Nothing -> + identity + + Just ClassVsClassNameValidation -> + Json.Decode.andThen + (\dict -> + if Dict.member "class" dict && Dict.member "className" dict then + -- Due to Json.Decode.Error API we need to drop down to strings. + Json.Decode.fail classVsClassNameValidationMessage + + else + Json.Decode.succeed dict + ) + ) ) @@ -374,8 +417,8 @@ decodeFacts (HtmlContext taggers eventDecoder) = decodeStyles (decodeEvents (eventDecoder taggers)) (Json.Decode.maybe (Json.Decode.field attributeNamespaceKey Json.Decode.value)) - (decodeOthers Json.Decode.string) - (decodeOthers Json.Decode.bool) + (decodeOthers Json.Decode.string (Just ClassVsClassNameValidation)) + (decodeOthers Json.Decode.bool Nothing) {-| Just empty facts diff --git a/src/Test/Html/Internal/ElmHtml/Query.elm b/src/Test/Html/Internal/ElmHtml/Query.elm index 64b1c36c..a1d519c4 100644 --- a/src/Test/Html/Internal/ElmHtml/Query.elm +++ b/src/Test/Html/Internal/ElmHtml/Query.elm @@ -262,8 +262,33 @@ hasStyle style facts = classnames : Facts msg -> List String classnames facts = - Dict.get "className" facts.stringAttributes - |> Maybe.withDefault "" + (case + ( Dict.get "class" facts.stringAttributes + , Dict.get "className" facts.stringAttributes + ) + of + ( Just _, Just _ ) -> + -- If you use both the `class` attribute and the `className` property at the same time, + -- it’s undefined which classes you end up with. It depends on which order they are specified, + -- which order elm/virtual-dom happens to apply them, and which of them changed most recently. + -- Mixing both is not a good idea. + -- + -- This code should be impossible to reach because of the validation in + -- Test.Html.Internal.ElmHtml.InternalTypes.decodeOthers. + -- + -- If we ever reach this code, silently claim that there are no classes (that no classes match + -- the node). + "" + + ( Just class, Nothing ) -> + class + + ( Nothing, Just className ) -> + className + + ( Nothing, Nothing ) -> + "" + ) |> String.split " " diff --git a/src/Test/Html/Internal/Inert.elm b/src/Test/Html/Internal/Inert.elm index fae19242..4af4f867 100644 --- a/src/Test/Html/Internal/Inert.elm +++ b/src/Test/Html/Internal/Inert.elm @@ -1,14 +1,15 @@ -module Test.Html.Internal.Inert exposing (Node, fromElmHtml, fromHtml, parseAttribute, toElmHtml) +module Test.Html.Internal.Inert exposing (Node, Error(..), fromElmHtml, fromHtml, parseAttribute, toElmHtml) {-| Inert Html - that is, can't do anything with events. -@docs Node, fromElmHtml, fromHtml, parseAttribute, toElmHtml +@docs Node, Error, fromElmHtml, fromHtml, parseAttribute, toElmHtml -} import Elm.Kernel.HtmlAsJson import Html exposing (Html) import Json.Decode +import MicroListExtra as List import Test.Html.Internal.ElmHtml.InternalTypes as InternalTypes exposing (ElmHtml, EventHandler, Tagger, decodeAttribute, decodeElmHtml) import VirtualDom @@ -17,14 +18,45 @@ type Node msg = Node (ElmHtml msg) -fromHtml : Html msg -> Result String (Node msg) +type Error + = DecodeError Json.Decode.Error + | ValidationErrors { deduped : List InternalTypes.Validation } + + +fromHtml : Html msg -> Result Error (Node msg) fromHtml html = case Json.Decode.decodeValue (decodeElmHtml taggedEventDecoder) (toJson html) of Ok elmHtml -> Ok (Node elmHtml) Err jsonError -> - Err (Json.Decode.errorToString jsonError) + case findValidationErrors jsonError of + [] -> + Err (DecodeError jsonError) + + failedValidations -> + Err (ValidationErrors { deduped = List.unique failedValidations }) + + +findValidationErrors : Json.Decode.Error -> List InternalTypes.Validation +findValidationErrors error = + case error of + Json.Decode.Field _ e -> + findValidationErrors e + + Json.Decode.Index _ e -> + findValidationErrors e + + Json.Decode.OneOf es -> + List.concatMap findValidationErrors es + + Json.Decode.Failure stringError _ -> + case InternalTypes.validationFromMessage stringError of + Nothing -> + [] + + Just validation -> + [ validation ] fromElmHtml : ElmHtml msg -> Node msg diff --git a/src/Test/Html/Query.elm b/src/Test/Html/Query.elm index 8c57f325..9d55179f 100644 --- a/src/Test/Html/Query.elm +++ b/src/Test/Html/Query.elm @@ -22,6 +22,8 @@ module Test.Html.Query exposing import Expect exposing (Expectation) import Html exposing (Html) +import Json.Decode +import Test.Html.Internal.ElmHtml.InternalTypes as InternalTypes import Test.Html.Internal.Inert as Inert import Test.Html.Query.Internal as Internal exposing (failWithQuery) import Test.Html.Selector exposing (Selector) @@ -90,8 +92,11 @@ fromHtml html = Ok node -> Internal.Query node [] - Err message -> - Internal.InternalError message + Err (Inert.DecodeError decodeError) -> + Internal.InternalError (Json.Decode.errorToString decodeError) + + Err (Inert.ValidationErrors validations) -> + Internal.ValidationErrors validations @@ -372,12 +377,23 @@ contains expectedHtml (Internal.Single showTrace query) = |> failWithQuery showTrace "Query.contains" query Err errors -> - Expect.fail <| - String.join "\n" <| - List.concat - [ [ "Internal Error: failed to decode the virtual dom. Please report this at ." ] - , errors - ] + errors + |> List.map + (\error -> + (case error of + Inert.DecodeError decodeError -> + [ "Internal Error: failed to decode the virtual dom. Please report this at ." + , Json.Decode.errorToString decodeError + ] + + Inert.ValidationErrors { deduped } -> + deduped + |> List.map InternalTypes.validationMessage + ) + |> String.join "\n" + ) + |> String.join "\n\n" + |> Expect.fail collectResults : List (Result x a) -> Result (List x) (List a) diff --git a/src/Test/Html/Query/Internal.elm b/src/Test/Html/Query/Internal.elm index 27e8374c..0cacd3d3 100644 --- a/src/Test/Html/Query/Internal.elm +++ b/src/Test/Html/Query/Internal.elm @@ -2,7 +2,7 @@ module Test.Html.Query.Internal exposing (Multiple(..), Query(..), QueryError(.. import Expect exposing (Expectation) import Test.Html.Descendant as Descendant -import Test.Html.Internal.ElmHtml.InternalTypes exposing (ElmHtml(..)) +import Test.Html.Internal.ElmHtml.InternalTypes as InternalTypes exposing (ElmHtml(..)) import Test.Html.Internal.ElmHtml.ToString exposing (nodeToStringWithOptions) import Test.Html.Internal.Inert as Inert import Test.Html.Selector.Internal as InternalSelector exposing (Selector, selectorToString) @@ -14,6 +14,7 @@ import Test.Runner type Query msg = Query (Inert.Node msg) (List SelectorQuery) | InternalError String + | ValidationErrors { deduped : List InternalTypes.Validation } type SelectorQuery @@ -47,19 +48,32 @@ type QueryError = NoResultsForSingle String | MultipleResultsForSingle String Int | OtherInternalError String + | QueryValidationErrors { deduped : List InternalTypes.Validation } -toLines : String -> Query msg -> String -> List String -toLines expectationFailure query queryName = +toLines : { showQueryError : Bool } -> String -> Query msg -> String -> List String +toLines { showQueryError } expectationFailure query queryName = case query of Query node selectors -> toLinesHelp expectationFailure [ Inert.toElmHtml node ] (List.reverse selectors) queryName [] |> List.reverse InternalError message -> - [ "Internal Error: failed to decode the virtual dom. Please report this at " - , message - ] + if showQueryError then + [ "Internal Error: failed to decode the virtual dom. Please report this at . " + , message + ] + + else + [] + + ValidationErrors { deduped } -> + if showQueryError then + deduped + |> List.map InternalTypes.validationMessage + + else + [] prettyPrint : ElmHtml msg -> String @@ -77,6 +91,11 @@ toOutputLine query = "Internal Error: failed to decode the virtual dom. Please report this at . " ++ message + ValidationErrors { deduped } -> + deduped + |> List.map InternalTypes.validationMessage + |> String.join "\n\n" + toLinesHelp : String -> List (ElmHtml msg) -> List SelectorQuery -> String -> List String -> List String toLinesHelp expectationFailure elmHtmlList selectorQueries queryName results = @@ -243,6 +262,9 @@ prependSelector query selector = InternalError message -> InternalError message + ValidationErrors validations -> + ValidationErrors validations + {-| This is a more efficient implementation of the following: @@ -300,6 +322,9 @@ traverse query = InternalError message -> Err (OtherInternalError message) + ValidationErrors validations -> + Err (QueryValidationErrors validations) + traverseSelectors : List SelectorQuery -> List (ElmHtml msg) -> Result QueryError (List (ElmHtml msg)) traverseSelectors selectorQueries elmHtmlList = @@ -452,6 +477,11 @@ queryErrorToString error = "Internal Error: failed to decode the virtual dom. Please report this at . " ++ message + QueryValidationErrors { deduped } -> + deduped + |> List.map InternalTypes.validationMessage + |> String.join "\n\n" + contains : List (ElmHtml msg) -> Query msg -> Expectation contains expectedDescendants query = @@ -572,7 +602,7 @@ failWithQuery showTrace queryName query expectation = Just { description } -> let lines = - toLines description query queryName + toLines { showQueryError = not showTrace } description query queryName |> List.map prefixOutputLine tracedLines = diff --git a/tests/src/Test/Html/QueryTests.elm b/tests/src/Test/Html/QueryTests.elm index 134ff5c2..198d7b01 100644 --- a/tests/src/Test/Html/QueryTests.elm +++ b/tests/src/Test/Html/QueryTests.elm @@ -113,6 +113,27 @@ all = [ Query.has [ attribute (Attr.property "className" (Encode.string "hello world")) ] , Query.has [ attribute (Attr.property "className" (Encode.string "world hello")) ] ] + , test "matches a class added using Attr.attribute" <| + \() -> + divWithAttribute (Attr.attribute "class" "hello") + |> Query.fromHtml + |> Query.has [ class "hello" ] + , test "matches a class added using Attr.property" <| + \() -> + divWithAttribute (Attr.property "className" (Encode.string "hello")) + |> Query.fromHtml + |> Query.has [ class "hello" ] + , test "matches nothing if classes are added both using Attr.attribute and Attr.property" <| + \() -> + Html.div + [ Attr.attribute "class" "hello" + , Attr.property "className" (Encode.string "world") + ] + [] + |> Query.fromHtml + |> Query.has [ class "hello" ] + |> expectationToIsPassing + |> Expect.equal False ] ] , describe "Query.contains" <|