From 73306526dd057d7e7254f52a01f9c513c54ff24d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Melvyn=20La=C3=AFly?= Date: Sun, 16 Mar 2025 21:03:21 +0100 Subject: [PATCH 1/3] Fix options not being considered as DU in the tracer The previous implementation could actually crash: if the input is Some(DUCase), Fable.Core.Reflection.isUnion returns true because it does not "see" the option, and only see the wrapped DUCase. Reflection.FSharpType.GetUnionCases() would then attempt to get the fields of the input, and since option types are not considered DU under Fable, it would throw. --- RELEASE_NOTES.md | 3 + src/tracers.fs | 72 +++++++++++++--- tests/Fable.Elmish.Browser.Tests.fsproj | 1 + tests/TracersTests.fs | 107 ++++++++++++++++++++++++ 4 files changed, 170 insertions(+), 13 deletions(-) create mode 100644 tests/TracersTests.fs diff --git a/RELEASE_NOTES.md b/RELEASE_NOTES.md index e4ca51a..9c2cd59 100644 --- a/RELEASE_NOTES.md +++ b/RELEASE_NOTES.md @@ -1,3 +1,6 @@ +## 4.1.0 +* Fix support for `Option`s in Elmish.Tracers.console + ## 4.0.3 * Small optimization in param parsing diff --git a/src/tracers.fs b/src/tracers.fs index 0020eb8..70bad81 100644 --- a/src/tracers.fs +++ b/src/tracers.fs @@ -5,32 +5,78 @@ open System open Fable.Core let getMsgNameAndFields (t: Type) (x: 'Msg) : string * obj = - let rec getCaseName (t: Type) (acc: string list) (x: obj) = - let caseName = Reflection.getCaseName x - let uci = - Reflection.FSharpType.GetUnionCases(t) - |> Array.find (fun uci -> uci.Name = caseName) + let getLongName (t: Type) = sprintf "%s.%s"t.Namespace t.Name + + let isOption (t: Type) = getLongName t = "Microsoft.FSharp.Core.FSharpOption`1" + + let isUnion (t: Type) = isOption t || Reflection.FSharpType.IsUnion t - let acc = (Reflection.getCaseName x) :: acc - let fields = Reflection.getCaseFields x + let getUnionFields x (t: Type) = + if isOption t then + // Options are special-cased because they are erased by Fable, + // and thus do not return true for IsUnion(). + // (IsUnion() returns true for options on platforms other than Fable) + let value = box x + if isNull value then + {| + CaseName = "None" + FieldsValues = [||] + FieldsTypes = [||] + |} + else + let value = + #if FABLE_COMPILER + value + #else + let _, field = FSharp.Reflection.FSharpValue.GetUnionFields(value, t) + field[0] + #endif + let valueType = t.GenericTypeArguments[0] + {| + CaseName = "Some" + FieldsValues = [| value |] + FieldsTypes = [| {| Type = valueType; FieldName = "Value"; IsUnion = isUnion valueType |} |] + + |} + else // Not a Union: + let uci, ucFields = Reflection.FSharpValue.GetUnionFields(x, t) + {| + CaseName = uci.Name + FieldsValues = ucFields + FieldsTypes = + uci.GetFields() + |> Array.map (fun x ->{| + Type = x.PropertyType + FieldName = x.Name + IsUnion = isUnion x.PropertyType |}) + |} + + let rec getCaseName (t: Type) (acc: string list) (x: obj) = + let ucInfo = getUnionFields x t + let acc = ucInfo.CaseName :: acc - if fields.Length = 1 && Reflection.isUnion fields.[0] then - getCaseName (uci.GetFields().[0].PropertyType) acc fields.[0] - else + match ucInfo.FieldsTypes with + | [| fieldInfo |] when fieldInfo.IsUnion -> getCaseName fieldInfo.Type acc ucInfo.FieldsValues[0] + | fieldsTypes -> // Case names are intentionally left reverted so we see // the most meaningful message first let msgName = acc |> String.concat "/" let fields = - (uci.GetFields(), fields) + (fieldsTypes, ucInfo.FieldsValues) ||> Array.zip - |> Array.map (fun (fi, v) -> fi.Name, v) + |> Array.map (fun (fi, v) -> fi.FieldName, v) + #if FABLE_COMPILER |> JsInterop.createObj + #else + |> List.ofArray // So that we can compare the result by value in the unit tests... + |> box + #endif msgName, fields - if Reflection.isUnion x then + if isUnion t then getCaseName t [] x else "Msg", box x diff --git a/tests/Fable.Elmish.Browser.Tests.fsproj b/tests/Fable.Elmish.Browser.Tests.fsproj index 4948107..8c4f131 100644 --- a/tests/Fable.Elmish.Browser.Tests.fsproj +++ b/tests/Fable.Elmish.Browser.Tests.fsproj @@ -6,6 +6,7 @@ + diff --git a/tests/TracersTests.fs b/tests/TracersTests.fs new file mode 100644 index 0000000..831c4be --- /dev/null +++ b/tests/TracersTests.fs @@ -0,0 +1,107 @@ +module Elmish.TracersTests + +open Swensen.Unquote +open NUnit.Framework + +type ChildMsg = + | ChildMsgNoField + | ChildMsgOneIntField of int + | ChildMsgTwoStringAndIntField of childStr: string * childInt: int + +type RootMsg = + | RootMsgNoField + | RootMsgOneIntField of int + | RootMsgTwoStringAndIntField of str: string * int: int + | RootMsgOneChildField of ChildMsg + | RootMsgOneIntOptionField of int option + | RootMsgOneChildOptionField of ChildMsg option + | RootMsgIntOptionOption of int option option + +let getTraceForMsg (msg: 'Msg) = + let actualName, actualValues = Tracers.getMsgNameAndFields typeof<'Msg> msg + let actualValues = actualValues :?> (string * obj) list + actualName, actualValues + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgNoField`` () = + getTraceForMsg (RootMsg.RootMsgNoField) + =! (nameof (RootMsg.RootMsgNoField), + []) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgOneIntField`` () = + getTraceForMsg (RootMsg.RootMsgOneIntField 42) + =! (nameof (RootMsg.RootMsgOneIntField), + [ ("Item", 42) ]) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgTwoStringAndIntField`` () = + getTraceForMsg (RootMsg.RootMsgTwoStringAndIntField("test", 42)) + =! (nameof (RootMsg.RootMsgTwoStringAndIntField), + [ ("str", "test"); ("int", 42) ]) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgOneChildField, ChildMsg.ChildMsgNoField`` () = + getTraceForMsg (RootMsg.RootMsgOneChildField(ChildMsg.ChildMsgNoField)) + =! ($"{nameof ChildMsg.ChildMsgNoField}/{nameof (RootMsg.RootMsgOneChildField)}", + []) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgOneChildField, ChildMsg.ChildMsgOneIntField`` () = + getTraceForMsg (RootMsg.RootMsgOneChildField(ChildMsg.ChildMsgOneIntField(42))) + =! ($"{nameof ChildMsg.ChildMsgOneIntField}/{nameof (RootMsg.RootMsgOneChildField)}", + [ ("Item", 42) ]) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgOneChildField, ChildMsg.ChildMsgTwoStringAndIntField`` () = + getTraceForMsg (RootMsg.RootMsgOneChildField(ChildMsg.ChildMsgTwoStringAndIntField("test", 42))) + =! ($"{nameof ChildMsg.ChildMsgTwoStringAndIntField}/{nameof (RootMsg.RootMsgOneChildField)}", + [ ("childStr", "test"); ("childInt", 42) ]) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgOneIntOptionField, None`` () = + getTraceForMsg (RootMsg.RootMsgOneIntOptionField(None)) + =! ($"None/{nameof (RootMsg.RootMsgOneIntOptionField)}", + []) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgOneIntOptionField, Some`` () = + getTraceForMsg (RootMsg.RootMsgOneIntOptionField(Some 42)) + =! ($"Some/{nameof (RootMsg.RootMsgOneIntOptionField)}", + [ ("Value", 42) ]) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, None`` () = + getTraceForMsg (RootMsg.RootMsgOneChildOptionField(None)) + =! ($"None/{nameof (RootMsg.RootMsgOneChildOptionField)}", + []) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, Some ChildMsgNoField`` () = + getTraceForMsg (RootMsg.RootMsgOneChildOptionField(Some(ChildMsgNoField))) + =! ($"{nameof (ChildMsg.ChildMsgNoField)}/Some/{nameof (RootMsg.RootMsgOneChildOptionField)}", + []) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, Some ChildMsgOneIntField`` () = + getTraceForMsg (RootMsg.RootMsgOneChildOptionField(Some(ChildMsgOneIntField 42))) + =! ($"{nameof (ChildMsg.ChildMsgOneIntField)}/Some/{nameof (RootMsg.RootMsgOneChildOptionField)}", + [ ("Item", 42) ]) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, Some ChildMsgTwoStringAndIntField`` () = + getTraceForMsg (RootMsg.RootMsgOneChildOptionField(Some(ChildMsgTwoStringAndIntField("test", 42)))) + =! ($"{nameof (ChildMsg.ChildMsgTwoStringAndIntField)}/Some/{nameof (RootMsg.RootMsgOneChildOptionField)}", + [ ("childStr", "test"); ("childInt", 42) ]) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgIntOptionOption, Some, None`` () = + getTraceForMsg (RootMsg.RootMsgIntOptionOption(Some(None))) + =! ($"None/Some/{nameof (RootMsg.RootMsgIntOptionOption)}", + []) + +[] +let ``getMsgNameAndFields for RootMsg.RootMsgIntOptionOption, Some, Some`` () = + getTraceForMsg (RootMsg.RootMsgIntOptionOption(Some(Some 42))) + =! ($"Some/Some/{nameof (RootMsg.RootMsgIntOptionOption)}", + [ ("Value", 42) ]) From 5b46ab04a36f16de6fce74d62580fcd501ae1304 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Melvyn=20La=C3=AFly?= Date: Mon, 17 Mar 2025 16:12:27 +0100 Subject: [PATCH 2/3] Pin build.fsx dependencies versions to fix the failing build --- build.fsx | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/build.fsx b/build.fsx index 6d97467..9c92b36 100755 --- a/build.fsx +++ b/build.fsx @@ -1,10 +1,10 @@ #!/usr/bin/env -S dotnet fsi -#r "nuget: Fake.Core.Target" -#r "nuget: Fake.IO.FileSystem" -#r "nuget: Fake.DotNet.Cli" -#r "nuget: Fake.Core.Target" -#r "nuget: Fake.Core.ReleaseNotes" -#r "nuget: Fake.Tools.Git" +#r "nuget: Fake.Core.Target, 5.23.1" +#r "nuget: Fake.IO.FileSystem, 5.23.1" +#r "nuget: Fake.DotNet.Cli, 5.23.1" +#r "nuget: Fake.Core.Target, 5.23.1" +#r "nuget: Fake.Core.ReleaseNotes, 5.23.1" +#r "nuget: Fake.Tools.Git, 5.23.1" open Fake.Core open Fake.Core.TargetOperators From 208dde2a9e74f58aec2f1ee236ce95d2f6535c5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Melvyn=20La=C3=AFly?= Date: Wed, 19 Mar 2025 07:22:12 +0100 Subject: [PATCH 3/3] Convert array to list only in the tracers unit tests --- src/tracers.fs | 1 - tests/TracersTests.fs | 4 +++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/tracers.fs b/src/tracers.fs index 70bad81..bb6583f 100644 --- a/src/tracers.fs +++ b/src/tracers.fs @@ -70,7 +70,6 @@ let getMsgNameAndFields (t: Type) (x: 'Msg) : string * obj = #if FABLE_COMPILER |> JsInterop.createObj #else - |> List.ofArray // So that we can compare the result by value in the unit tests... |> box #endif diff --git a/tests/TracersTests.fs b/tests/TracersTests.fs index 831c4be..8bc8acb 100644 --- a/tests/TracersTests.fs +++ b/tests/TracersTests.fs @@ -19,7 +19,9 @@ type RootMsg = let getTraceForMsg (msg: 'Msg) = let actualName, actualValues = Tracers.getMsgNameAndFields typeof<'Msg> msg - let actualValues = actualValues :?> (string * obj) list + let actualValues = + actualValues :?> (string * obj) array + |> Array.toList // So that we can compare the actual vs expected by value in the tests. actualName, actualValues []