Skip to content

Commit d0ec296

Browse files
mlailymlaily
committed
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.
1 parent b381c49 commit d0ec296

File tree

3 files changed

+167
-13
lines changed

3 files changed

+167
-13
lines changed

‎src/tracers.fs‎

Lines changed: 59 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -5,32 +5,78 @@ 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+
|> List.ofArray // So that we can compare the result by value in the unit tests...
74+
|> box
75+
#endif
3076

3177
msgName, fields
3278

33-
if Reflection.isUnion x then
79+
if isUnion t then
3480
getCaseName t [] x
3581
else
3682
"Msg", box x

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

Lines changed: 1 addition & 0 deletions
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‎

Lines changed: 107 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,107 @@
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 = actualValues :?> (string * obj) list
23+
actualName, actualValues
24+
25+
[<Test>]
26+
let ``getMsgNameAndFields for RootMsg.RootMsgNoField`` () =
27+
getTraceForMsg (RootMsg.RootMsgNoField)
28+
=! (nameof (RootMsg.RootMsgNoField),
29+
[])
30+
31+
[<Test>]
32+
let ``getMsgNameAndFields for RootMsg.RootMsgOneIntField`` () =
33+
getTraceForMsg (RootMsg.RootMsgOneIntField 42)
34+
=! (nameof (RootMsg.RootMsgOneIntField),
35+
[ ("Item", 42) ])
36+
37+
[<Test>]
38+
let ``getMsgNameAndFields for RootMsg.RootMsgTwoStringAndIntField`` () =
39+
getTraceForMsg (RootMsg.RootMsgTwoStringAndIntField("test", 42))
40+
=! (nameof (RootMsg.RootMsgTwoStringAndIntField),
41+
[ ("str", "test"); ("int", 42) ])
42+
43+
[<Test>]
44+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildField, ChildMsg.ChildMsgNoField`` () =
45+
getTraceForMsg (RootMsg.RootMsgOneChildField(ChildMsg.ChildMsgNoField))
46+
=! ($"{nameof ChildMsg.ChildMsgNoField}/{nameof (RootMsg.RootMsgOneChildField)}",
47+
[])
48+
49+
[<Test>]
50+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildField, ChildMsg.ChildMsgOneIntField`` () =
51+
getTraceForMsg (RootMsg.RootMsgOneChildField(ChildMsg.ChildMsgOneIntField(42)))
52+
=! ($"{nameof ChildMsg.ChildMsgOneIntField}/{nameof (RootMsg.RootMsgOneChildField)}",
53+
[ ("Item", 42) ])
54+
55+
[<Test>]
56+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildField, ChildMsg.ChildMsgTwoStringAndIntField`` () =
57+
getTraceForMsg (RootMsg.RootMsgOneChildField(ChildMsg.ChildMsgTwoStringAndIntField("test", 42)))
58+
=! ($"{nameof ChildMsg.ChildMsgTwoStringAndIntField}/{nameof (RootMsg.RootMsgOneChildField)}",
59+
[ ("childStr", "test"); ("childInt", 42) ])
60+
61+
[<Test>]
62+
let ``getMsgNameAndFields for RootMsg.RootMsgOneIntOptionField, None`` () =
63+
getTraceForMsg (RootMsg.RootMsgOneIntOptionField(None))
64+
=! ($"None/{nameof (RootMsg.RootMsgOneIntOptionField)}",
65+
[])
66+
67+
[<Test>]
68+
let ``getMsgNameAndFields for RootMsg.RootMsgOneIntOptionField, Some`` () =
69+
getTraceForMsg (RootMsg.RootMsgOneIntOptionField(Some 42))
70+
=! ($"Some/{nameof (RootMsg.RootMsgOneIntOptionField)}",
71+
[ ("Value", 42) ])
72+
73+
[<Test>]
74+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, None`` () =
75+
getTraceForMsg (RootMsg.RootMsgOneChildOptionField(None))
76+
=! ($"None/{nameof (RootMsg.RootMsgOneChildOptionField)}",
77+
[])
78+
79+
[<Test>]
80+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, Some ChildMsgNoField`` () =
81+
getTraceForMsg (RootMsg.RootMsgOneChildOptionField(Some(ChildMsgNoField)))
82+
=! ($"{nameof (ChildMsg.ChildMsgNoField)}/Some/{nameof (RootMsg.RootMsgOneChildOptionField)}",
83+
[])
84+
85+
[<Test>]
86+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, Some ChildMsgOneIntField`` () =
87+
getTraceForMsg (RootMsg.RootMsgOneChildOptionField(Some(ChildMsgOneIntField 42)))
88+
=! ($"{nameof (ChildMsg.ChildMsgOneIntField)}/Some/{nameof (RootMsg.RootMsgOneChildOptionField)}",
89+
[ ("Item", 42) ])
90+
91+
[<Test>]
92+
let ``getMsgNameAndFields for RootMsg.RootMsgOneChildOptionField, Some ChildMsgTwoStringAndIntField`` () =
93+
getTraceForMsg (RootMsg.RootMsgOneChildOptionField(Some(ChildMsgTwoStringAndIntField("test", 42))))
94+
=! ($"{nameof (ChildMsg.ChildMsgTwoStringAndIntField)}/Some/{nameof (RootMsg.RootMsgOneChildOptionField)}",
95+
[ ("childStr", "test"); ("childInt", 42) ])
96+
97+
[<Test>]
98+
let ``getMsgNameAndFields for RootMsg.RootMsgIntOptionOption, Some, None`` () =
99+
getTraceForMsg (RootMsg.RootMsgIntOptionOption(Some(None)))
100+
=! ($"None/Some/{nameof (RootMsg.RootMsgIntOptionOption)}",
101+
[])
102+
103+
[<Test>]
104+
let ``getMsgNameAndFields for RootMsg.RootMsgIntOptionOption, Some, Some`` () =
105+
getTraceForMsg (RootMsg.RootMsgIntOptionOption(Some(Some 42)))
106+
=! ($"Some/Some/{nameof (RootMsg.RootMsgIntOptionOption)}",
107+
[ ("Value", 42) ])

0 commit comments

Comments
 (0)