Skip to content

Commit dc8ba8d

Browse files
mlailyMelvyn Laïly
mlaily
and
Melvyn Laïly
authored
Fix tracer support for options (was crashing) (#77)
* 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. * Pin build.fsx dependencies versions to fix the failing build * Convert array to list only in the tracers unit tests --------- Co-authored-by: Melvyn Laïly <mlaily@d-edge.com>
1 parent b381c49 commit dc8ba8d

File tree

5 files changed

+177
-19
lines changed

5 files changed

+177
-19
lines changed

‎RELEASE_NOTES.md

+3
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,6 @@
1+
## 4.1.0
2+
* Fix support for `Option`s in Elmish.Tracers.console
3+
14
## 4.0.3
25
* Small optimization in param parsing
36

‎build.fsx

+6-6
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,10 @@
11
#!/usr/bin/env -S dotnet fsi
2-
#r "nuget: Fake.Core.Target"
3-
#r "nuget: Fake.IO.FileSystem"
4-
#r "nuget: Fake.DotNet.Cli"
5-
#r "nuget: Fake.Core.Target"
6-
#r "nuget: Fake.Core.ReleaseNotes"
7-
#r "nuget: Fake.Tools.Git"
2+
#r "nuget: Fake.Core.Target, 5.23.1"
3+
#r "nuget: Fake.IO.FileSystem, 5.23.1"
4+
#r "nuget: Fake.DotNet.Cli, 5.23.1"
5+
#r "nuget: Fake.Core.Target, 5.23.1"
6+
#r "nuget: Fake.Core.ReleaseNotes, 5.23.1"
7+
#r "nuget: Fake.Tools.Git, 5.23.1"
88

99
open Fake.Core
1010
open Fake.Core.TargetOperators

‎src/tracers.fs

+58-13
Original file line numberDiff line numberDiff line change
@@ -5,32 +5,77 @@ open System
55
open Fable.Core
66

77
let getMsgNameAndFields (t: Type) (x: 'Msg) : string * obj =
8-
let rec getCaseName (t: Type) (acc: string list) (x: obj) =
9-
let caseName = Reflection.getCaseName x
108

11-
let uci =
12-
Reflection.FSharpType.GetUnionCases(t)
13-
|> Array.find (fun uci -> uci.Name = caseName)
9+
let getLongName (t: Type) = sprintf "%s.%s"t.Namespace t.Name
10+
11+
let isOption (t: Type) = getLongName t = "Microsoft.FSharp.Core.FSharpOption`1"
12+
13+
let isUnion (t: Type) = isOption t || Reflection.FSharpType.IsUnion t
1414

15-
let acc = (Reflection.getCaseName x) :: acc
16-
let fields = Reflection.getCaseFields x
15+
let getUnionFields x (t: Type) =
16+
if isOption t then
17+
// Options are special-cased because they are erased by Fable,
18+
// and thus do not return true for IsUnion().
19+
// (IsUnion() returns true for options on platforms other than Fable)
20+
let value = box x
21+
if isNull value then
22+
{|
23+
CaseName = "None"
24+
FieldsValues = [||]
25+
FieldsTypes = [||]
26+
|}
27+
else
28+
let value =
29+
#if FABLE_COMPILER
30+
value
31+
#else
32+
let _, field = FSharp.Reflection.FSharpValue.GetUnionFields(value, t)
33+
field[0]
34+
#endif
35+
let valueType = t.GenericTypeArguments[0]
36+
{|
37+
CaseName = "Some"
38+
FieldsValues = [| value |]
39+
FieldsTypes = [| {| Type = valueType; FieldName = "Value"; IsUnion = isUnion valueType |} |]
40+
41+
|}
42+
else // Not a Union:
43+
let uci, ucFields = Reflection.FSharpValue.GetUnionFields(x, t)
44+
{|
45+
CaseName = uci.Name
46+
FieldsValues = ucFields
47+
FieldsTypes =
48+
uci.GetFields()
49+
|> Array.map (fun x ->{|
50+
Type = x.PropertyType
51+
FieldName = x.Name
52+
IsUnion = isUnion x.PropertyType |})
53+
|}
54+
55+
let rec getCaseName (t: Type) (acc: string list) (x: obj) =
56+
let ucInfo = getUnionFields x t
57+
let acc = ucInfo.CaseName :: acc
1758

18-
if fields.Length = 1 && Reflection.isUnion fields.[0] then
19-
getCaseName (uci.GetFields().[0].PropertyType) acc fields.[0]
20-
else
59+
match ucInfo.FieldsTypes with
60+
| [| fieldInfo |] when fieldInfo.IsUnion -> getCaseName fieldInfo.Type acc ucInfo.FieldsValues[0]
61+
| fieldsTypes ->
2162
// Case names are intentionally left reverted so we see
2263
// the most meaningful message first
2364
let msgName = acc |> String.concat "/"
2465

2566
let fields =
26-
(uci.GetFields(), fields)
67+
(fieldsTypes, ucInfo.FieldsValues)
2768
||> Array.zip
28-
|> Array.map (fun (fi, v) -> fi.Name, v)
69+
|> Array.map (fun (fi, v) -> fi.FieldName, v)
70+
#if FABLE_COMPILER
2971
|> JsInterop.createObj
72+
#else
73+
|> box
74+
#endif
3075

3176
msgName, fields
3277

33-
if Reflection.isUnion x then
78+
if isUnion t then
3479
getCaseName t [] x
3580
else
3681
"Msg", box x

‎tests/Fable.Elmish.Browser.Tests.fsproj

+1
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
<ProjectReference Include="../src/Fable.Elmish.Browser.fsproj" />
77
</ItemGroup>
88
<ItemGroup>
9+
<Compile Include="TracersTests.fs" />
910
<Compile Include="ParserTests.fs" />
1011
</ItemGroup>
1112
<ItemGroup>

‎tests/TracersTests.fs

+109
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,109 @@
1+
module Elmish.TracersTests
2+
3+
open Swensen.Unquote
4+
open NUnit.Framework
5+
6+
type ChildMsg =
7+
| ChildMsgNoField
8+
| ChildMsgOneIntField of int
9+
| ChildMsgTwoStringAndIntField of childStr: string * childInt: int
10+
11+
type RootMsg =
12+
| RootMsgNoField
13+
| RootMsgOneIntField of int
14+
| RootMsgTwoStringAndIntField of str: string * int: int
15+
| RootMsgOneChildField of ChildMsg
16+
| RootMsgOneIntOptionField of int option
17+
| RootMsgOneChildOptionField of ChildMsg option
18+
| RootMsgIntOptionOption of int option option
19+
20+
let getTraceForMsg (msg: 'Msg) =
21+
let actualName, actualValues = Tracers.getMsgNameAndFields typeof<'Msg> msg
22+
let actualValues =
23+
actualValues :?> (string * obj) array
24+
|> Array.toList // So that we can compare the actual vs expected by value in the tests.
25+
actualName, actualValues
26+
27+
[<Test>]
28+
let ``getMsgNameAndFields for RootMsg.RootMsgNoField`` () =
29+
getTraceForMsg (RootMsg.RootMsgNoField)
30+
=! (nameof (RootMsg.RootMsgNoField),
31+
[])
32+
33+
[<Test>]
34+
let ``getMsgNameAndFields for RootMsg.RootMsgOneIntField`` () =
35+
getTraceForMsg (RootMsg.RootMsgOneIntField 42)
36+
=! (nameof (RootMsg.RootMsgOneIntField),
37+
[ ("Item", 42) ])
38+
39+
[<Test>]
40+
let ``getMsgNameAndFields for RootMsg.RootMsgTwoStringAndIntField`` () =
41+
getTraceForMsg (RootMsg.RootMsgTwoStringAndIntField("test", 42))
42+
=! (nameof (RootMsg.RootMsgTwoStringAndIntField),
43+
[ ("str", "test"); ("int", 42) ])
44+
45+
[<Test>]
46+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildField, ChildMsg.ChildMsgNoField`` () =
47+
getTraceForMsg (RootMsg.RootMsgOneChildField(ChildMsg.ChildMsgNoField))
48+
=! ($"{nameof ChildMsg.ChildMsgNoField}/{nameof (RootMsg.RootMsgOneChildField)}",
49+
[])
50+
51+
[<Test>]
52+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildField, ChildMsg.ChildMsgOneIntField`` () =
53+
getTraceForMsg (RootMsg.RootMsgOneChildField(ChildMsg.ChildMsgOneIntField(42)))
54+
=! ($"{nameof ChildMsg.ChildMsgOneIntField}/{nameof (RootMsg.RootMsgOneChildField)}",
55+
[ ("Item", 42) ])
56+
57+
[<Test>]
58+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildField, ChildMsg.ChildMsgTwoStringAndIntField`` () =
59+
getTraceForMsg (RootMsg.RootMsgOneChildField(ChildMsg.ChildMsgTwoStringAndIntField("test", 42)))
60+
=! ($"{nameof ChildMsg.ChildMsgTwoStringAndIntField}/{nameof (RootMsg.RootMsgOneChildField)}",
61+
[ ("childStr", "test"); ("childInt", 42) ])
62+
63+
[<Test>]
64+
let ``getMsgNameAndFields for RootMsg.RootMsgOneIntOptionField, None`` () =
65+
getTraceForMsg (RootMsg.RootMsgOneIntOptionField(None))
66+
=! ($"None/{nameof (RootMsg.RootMsgOneIntOptionField)}",
67+
[])
68+
69+
[<Test>]
70+
let ``getMsgNameAndFields for RootMsg.RootMsgOneIntOptionField, Some`` () =
71+
getTraceForMsg (RootMsg.RootMsgOneIntOptionField(Some 42))
72+
=! ($"Some/{nameof (RootMsg.RootMsgOneIntOptionField)}",
73+
[ ("Value", 42) ])
74+
75+
[<Test>]
76+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, None`` () =
77+
getTraceForMsg (RootMsg.RootMsgOneChildOptionField(None))
78+
=! ($"None/{nameof (RootMsg.RootMsgOneChildOptionField)}",
79+
[])
80+
81+
[<Test>]
82+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, Some ChildMsgNoField`` () =
83+
getTraceForMsg (RootMsg.RootMsgOneChildOptionField(Some(ChildMsgNoField)))
84+
=! ($"{nameof (ChildMsg.ChildMsgNoField)}/Some/{nameof (RootMsg.RootMsgOneChildOptionField)}",
85+
[])
86+
87+
[<Test>]
88+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, Some ChildMsgOneIntField`` () =
89+
getTraceForMsg (RootMsg.RootMsgOneChildOptionField(Some(ChildMsgOneIntField 42)))
90+
=! ($"{nameof (ChildMsg.ChildMsgOneIntField)}/Some/{nameof (RootMsg.RootMsgOneChildOptionField)}",
91+
[ ("Item", 42) ])
92+
93+
[<Test>]
94+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, Some ChildMsgTwoStringAndIntField`` () =
95+
getTraceForMsg (RootMsg.RootMsgOneChildOptionField(Some(ChildMsgTwoStringAndIntField("test", 42))))
96+
=! ($"{nameof (ChildMsg.ChildMsgTwoStringAndIntField)}/Some/{nameof (RootMsg.RootMsgOneChildOptionField)}",
97+
[ ("childStr", "test"); ("childInt", 42) ])
98+
99+
[<Test>]
100+
let ``getMsgNameAndFields for RootMsg.RootMsgIntOptionOption, Some, None`` () =
101+
getTraceForMsg (RootMsg.RootMsgIntOptionOption(Some(None)))
102+
=! ($"None/Some/{nameof (RootMsg.RootMsgIntOptionOption)}",
103+
[])
104+
105+
[<Test>]
106+
let ``getMsgNameAndFields for RootMsg.RootMsgIntOptionOption, Some, Some`` () =
107+
getTraceForMsg (RootMsg.RootMsgIntOptionOption(Some(Some 42)))
108+
=! ($"Some/Some/{nameof (RootMsg.RootMsgIntOptionOption)}",
109+
[ ("Value", 42) ])

0 commit comments

Comments
 (0)