Skip to content

Commit 48fb8de

Browse files
ncavencave
committed
Added support for erased records
1 parent fb3843a commit 48fb8de

File tree

12 files changed

+102
-31
lines changed

12 files changed

+102
-31
lines changed

‎.vscode/launch.json

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -65,8 +65,8 @@
6565
"name": "Run bench-compiler (.NET)",
6666
"program": "${workspaceFolder}/src/fable-standalone/test/bench-compiler/bin/Debug/netcoreapp3.1/bench-compiler.dll",
6767
// "args": ["${workspaceRoot}/tests/Main/Fable.Tests.fsproj", "out-tests"],
68-
// "args": ["${workspaceRoot}/../fable-test/fable-test.fsproj", "out-test", "--typescript"],
69-
"args": ["${workspaceRoot}/src/fable-library/Fable.Library.fsproj", "out-lib", "--typescript"],
68+
"args": ["${workspaceRoot}/../fable-test/fable-test.fsproj", "out-test", "--typescript"],
69+
// "args": ["${workspaceRoot}/src/fable-library/Fable.Library.fsproj", "out-lib", "--typescript"],
7070
"cwd": "${workspaceFolder}/src/fable-standalone/test/bench-compiler"
7171
},
7272
{

‎src/Fable.AST/Fable.fs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -266,6 +266,7 @@ type KeyKind =
266266
type GetKind =
267267
| ByKey of KeyKind
268268
| TupleIndex of int
269+
| FieldIndex of string * int
269270
| UnionField of index: int * fieldType: Type
270271
| UnionTag
271272
| ListHead

‎src/Fable.Transforms/FSharp2Fable.Util.fs

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -433,6 +433,10 @@ module Helpers =
433433
let makeRangeFrom (fsExpr: FSharpExpr) =
434434
Some (makeRange fsExpr.Range)
435435

436+
let isErasedRecord (com: Compiler) (t: FSharpType) =
437+
// TODO: check for custom equality or comparison
438+
com.Options.EraseUnions && t.HasTypeDefinition && t.TypeDefinition.IsFSharpRecord
439+
436440
let unionCaseTag (ent: FSharpEntity) (unionCase: FSharpUnionCase) =
437441
try
438442
ent.UnionCases |> Seq.findIndex (fun uci -> unionCase.Name = uci.Name)
@@ -697,8 +701,7 @@ module Patterns =
697701
match tryDefinition typ with
698702
| None -> failwith "Union without definition"
699703
| Some(tdef, fullName) ->
700-
let fullName = defaultArg fullName tdef.CompiledName
701-
match fullName with
704+
match defaultArg fullName tdef.CompiledName with
702705
| Types.valueOption
703706
| Types.option -> OptionUnion typ.GenericArguments.[0]
704707
| Types.list -> ListUnion typ.GenericArguments.[0]

‎src/Fable.Transforms/FSharp2Fable.fs

Lines changed: 28 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -643,21 +643,30 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) fsExpr =
643643

644644
// Getters and Setters
645645
| BasicPatterns.AnonRecordGet(callee, calleeType, fieldIndex) ->
646+
let r = makeRangeFrom fsExpr
646647
let! callee = transformExpr com ctx callee
647-
let fieldName = calleeType.AnonRecordTypeDetails.SortedFieldNames.[fieldIndex]
648648
let typ = makeType ctx.GenericArgs fsExpr.Type
649-
let key = FsField(fieldName, lazy typ) :> Fable.Field |> Fable.FieldKey
650-
return Fable.Get(callee, Fable.ByKey key, typ, makeRangeFrom fsExpr)
649+
let fieldName = calleeType.AnonRecordTypeDetails.SortedFieldNames.[fieldIndex]
650+
if isErasedRecord com calleeType then
651+
return Fable.Get(callee, Fable.FieldIndex(fieldName, fieldIndex), typ, r)
652+
else
653+
let key = FsField(fieldName, lazy typ) :> Fable.Field |> Fable.FieldKey
654+
return Fable.Get(callee, Fable.ByKey key, typ, r)
651655

652656
| BasicPatterns.FSharpFieldGet(callee, calleeType, field) ->
657+
let r = makeRangeFrom fsExpr
653658
let! callee = transformExprOpt com ctx callee
654659
let callee =
655660
match callee with
656661
| Some callee -> callee
657662
| None -> entityRef com (FsEnt calleeType.TypeDefinition)
658-
let key = FsField field :> Fable.Field |> Fable.FieldKey
659663
let typ = makeType ctx.GenericArgs fsExpr.Type
660-
return Fable.Get(callee, Fable.ByKey key, typ, makeRangeFrom fsExpr)
664+
if isErasedRecord com calleeType then
665+
let index = calleeType.TypeDefinition.FSharpFields |> Seq.findIndex (fun x -> x.Name = field.Name)
666+
return Fable.Get(callee, Fable.FieldIndex(field.Name, index + 1), typ, r)
667+
else
668+
let key = FsField field :> Fable.Field |> Fable.FieldKey
669+
return Fable.Get(callee, Fable.ByKey key, typ, r)
661670

662671
| BasicPatterns.TupleGet(_tupleType, tupleElemIndex, tupleExpr) ->
663672
let! tupleExpr = transformExpr com ctx tupleExpr
@@ -775,15 +784,24 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) fsExpr =
775784
return Fable.Sequential exprs
776785

777786
| BasicPatterns.NewRecord(fsType, argExprs) ->
787+
let r = makeRangeFrom fsExpr
778788
let! argExprs = transformExprList com ctx argExprs
779-
let genArgs = makeGenArgs ctx.GenericArgs (getGenericArguments fsType)
780-
return Fable.NewRecord(argExprs, FsEnt.Ref fsType.TypeDefinition, genArgs) |> makeValue (makeRangeFrom fsExpr)
789+
if isErasedRecord com fsType then
790+
let recordName = (makeStrConst (getFsTypeFullName fsType))
791+
return recordName::argExprs |> Fable.NewTuple |> makeValue r
792+
else
793+
let genArgs = makeGenArgs ctx.GenericArgs (getGenericArguments fsType)
794+
return Fable.NewRecord(argExprs, FsEnt.Ref fsType.TypeDefinition, genArgs) |> makeValue r
781795

782796
| BasicPatterns.NewAnonRecord(fsType, argExprs) ->
797+
let r = makeRangeFrom fsExpr
783798
let! argExprs = transformExprList com ctx argExprs
784-
let fieldNames = fsType.AnonRecordTypeDetails.SortedFieldNames
785-
let genArgs = makeGenArgs ctx.GenericArgs (getGenericArguments fsType)
786-
return Fable.NewAnonymousRecord(argExprs, fieldNames, genArgs) |> makeValue (makeRangeFrom fsExpr)
799+
if isErasedRecord com fsType then
800+
return argExprs |> Fable.NewTuple |> makeValue r
801+
else
802+
let fieldNames = fsType.AnonRecordTypeDetails.SortedFieldNames
803+
let genArgs = makeGenArgs ctx.GenericArgs (getGenericArguments fsType)
804+
return Fable.NewAnonymousRecord(argExprs, fieldNames, genArgs) |> makeValue r
787805

788806
| BasicPatterns.NewUnionCase(fsType, unionCase, argExprs) ->
789807
let! argExprs = transformExprList com ctx argExprs

‎src/Fable.Transforms/Fable2Babel.fs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1199,6 +1199,7 @@ module Util =
11991199
| Fable.ListTail ->
12001200
get range (com.TransformAsExpr(ctx, fableExpr)) "tail"
12011201

1202+
| Fable.FieldIndex (_, index)
12021203
| Fable.TupleIndex index ->
12031204
match fableExpr with
12041205
// TODO: Check the erased expressions don't have side effects?

‎src/Fable.Transforms/FableTransforms.fs

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -59,8 +59,8 @@ let visit f e =
5959
Operation(Logical(op, f left, f right), t, r)
6060
| Get(e, kind, t, r) ->
6161
match kind with
62-
| ListHead | ListTail | OptionValue | TupleIndex _ | UnionTag
63-
| UnionField _ | ByKey(FieldKey _) -> Get(f e, kind, t, r)
62+
| ListHead | ListTail | OptionValue | TupleIndex _ | FieldIndex _
63+
| UnionTag | UnionField _ | ByKey(FieldKey _) -> Get(f e, kind, t, r)
6464
| ByKey(ExprKey e2) -> Get(f e, ByKey(ExprKey(f e2)), t, r)
6565
| Sequential exprs -> Sequential(List.map f exprs)
6666
| Let(ident, value, body) -> Let(ident, f value, f body)
@@ -131,8 +131,8 @@ let getSubExpressions = function
131131
| Logical(_, left, right) -> [left; right]
132132
| Get(e, kind, _, _) ->
133133
match kind with
134-
| ListHead | ListTail | OptionValue | TupleIndex _ | UnionTag
135-
| UnionField _ | ByKey(FieldKey _) -> [e]
134+
| ListHead | ListTail | OptionValue | TupleIndex _ | FieldIndex _
135+
| UnionTag | UnionField _ | ByKey(FieldKey _) -> [e]
136136
| ByKey(ExprKey e2) -> [e; e2]
137137
| Sequential exprs -> exprs
138138
| Let(_, value, body) -> [value; body]

‎src/Fable.Transforms/Replacements.fs

Lines changed: 49 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -217,6 +217,7 @@ let (|Nameof|_|) com ctx = function
217217
| IdentExpr ident -> Some ident.DisplayName
218218
| Get(_, ByKey(ExprKey(StringConst prop)), _, _) -> Some prop
219219
| Get(_, ByKey(FieldKey fi), _, _) -> Some fi.Name
220+
| Get(_, FieldIndex(fieldName, _), _, _) -> Some fieldName
220221
| NestedLambda(args, Call(IdentExpr ident, info, _, _), None) ->
221222
if List.sameLength args info.Args && List.zip args info.Args |> List.forall (fun (a1, a2) ->
222223
match a2 with IdentExpr id2 -> a1.Name = id2.Name | _ -> false)
@@ -695,6 +696,50 @@ let isCompatibleWithJsComparison = function
695696
// * `.GetHashCode` called directly defaults to identity hash (for reference types except string) if not implemented.
696697
// * `LanguagePrimitive.PhysicalHash` creates an identity hash no matter whether GetHashCode is implemented or not.
697698

699+
let getEntityHashMethod (com: ICompiler) (ent: Entity) =
700+
if (ent.IsFSharpUnion || ent.IsFSharpRecord) then
701+
if com.Options.EraseUnions
702+
then "Util", "structuralHash"
703+
else "Util", "hashSafe"
704+
elif ent.IsValueType
705+
then "Util", "hashSafe"
706+
else "Util", "identityHash"
707+
708+
let getEntityEqualsMethod (com: ICompiler) (ent: Entity) =
709+
if (ent.IsFSharpUnion || ent.IsFSharpRecord) then
710+
if com.Options.EraseUnions
711+
then "Util", "equals"
712+
else "Util", "equalsSafe"
713+
elif ent.IsValueType
714+
then "Util", "equalsSafe"
715+
else "Util", "equals"
716+
717+
let getEntityCompareMethod (com: ICompiler) (ent: Entity) =
718+
if (ent.IsFSharpUnion || ent.IsFSharpRecord) then
719+
if com.Options.EraseUnions
720+
then "Util", "compare"
721+
else "Util", "compareSafe"
722+
elif ent.IsValueType
723+
then "Util", "compareSafe"
724+
else "Util", "compare"
725+
726+
let identityHashMethod (com: ICompiler) = function
727+
| Boolean | Char | String | Number _ | Enum _ | Option _ | Tuple _ | List _
728+
| Builtin (BclInt64 | BclUInt64 | BclDecimal | BclBigInt)
729+
| Builtin (BclGuid | BclTimeSpan | BclDateTime | BclDateTimeOffset)
730+
| Builtin (FSharpSet _ | FSharpMap _ | FSharpChoice _ | FSharpResult _) ->
731+
"Util", "structuralHash"
732+
| DeclaredType(ent, _) -> com.GetEntity(ent) |> getEntityHashMethod com
733+
| _ -> "Util", "identityHash"
734+
735+
let structuralHashMethod (com: ICompiler) = function
736+
| MetaType -> "Reflection", "getHashCode"
737+
| DeclaredType(ent, _) ->
738+
let ent = com.GetEntity(ent)
739+
if not ent.IsInterface then getEntityHashMethod com ent
740+
else "Util", "structuralHash"
741+
| _ -> "Util", "structuralHash"
742+
698743
let identityHash com r (arg: Expr) =
699744
let methodName =
700745
match arg.Type with
@@ -747,10 +792,8 @@ let rec equals (com: ICompiler) ctx r equal (left: Expr) (right: Expr) =
747792
Helper.LibCall(com, coreModFor bt, "equals", Boolean, [left; right], ?loc=r) |> is equal
748793
| DeclaredType(ent, _) ->
749794
let ent = com.GetEntity(ent)
750-
if ent.IsFSharpUnion || ent.IsFSharpRecord || ent.IsValueType then
751-
Helper.LibCall(com, "Util", "equalsSafe", Boolean, [left; right], ?loc=r) |> is equal
752-
else
753-
Helper.LibCall(com, "Util", "equals", Boolean, [left; right], ?loc=r) |> is equal
795+
let moduleName, methodName = getEntityEqualsMethod com ent
796+
Helper.LibCall(com, moduleName, methodName, Boolean, [left; right], ?loc=r) |> is equal
754797
| Array t ->
755798
let f = makeComparerFunction com ctx t
756799
Helper.LibCall(com, "Array", "equalsWith", Boolean, [f; left; right], ?loc=r) |> is equal
@@ -775,10 +818,8 @@ and compare (com: ICompiler) ctx r (left: Expr) (right: Expr) =
775818
Helper.LibCall(com, coreModFor bt, "compare", Number Int32, [left; right], ?loc=r)
776819
| DeclaredType(ent, _) ->
777820
let ent = com.GetEntity(ent)
778-
if ent.IsFSharpUnion || ent.IsFSharpRecord || ent.IsValueType then
779-
Helper.LibCall(com, "Util", "compareSafe", Number Int32, [left; right], ?loc=r)
780-
else
781-
Helper.LibCall(com, "Util", "compare", Number Int32, [left; right], ?loc=r)
821+
let moduleName, methodName = getEntityCompareMethod com ent
822+
Helper.LibCall(com, moduleName, methodName, Number Int32, [left; right], ?loc=r)
782823
| Array t ->
783824
let f = makeComparerFunction com ctx t
784825
Helper.LibCall(com, "Array", "compareWith", Number Int32, [f; left; right], ?loc=r)

‎src/fable-standalone/src/Interfaces.fs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -64,7 +64,9 @@ type IFableManager =
6464
abstract GetToolTipText: parseResults: IParseResults * line: int * col: int * lineText: string -> string[]
6565
abstract GetCompletionsAtLocation: parseResults: IParseResults * line: int * col: int * lineText: string -> Completion[]
6666
abstract CompileToBabelAst: fableLibrary: string * parseResults: IParseResults * fileName: string
67+
* ?eraseUnions: bool
6768
* ?typedArrays: bool
68-
* ?typescript: bool -> IBabelResult
69+
* ?typescript: bool
70+
-> IBabelResult
6971
abstract PrintBabelAst: babelResult: IBabelResult * IWriter -> Async<unit>
7072
abstract FSharpAstToString: parseResults: IParseResults * fileName: string -> string

‎src/fable-standalone/src/Main.fs

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -258,14 +258,16 @@ let init () =
258258
getCompletionsAtLocation res line col lineText
259259

260260
member __.CompileToBabelAst(fableLibrary:string, parseResults:IParseResults, fileName:string,
261-
?typedArrays, ?typescript) =
261+
?eraseUnions, ?typedArrays, ?typescript) =
262262
let res = parseResults :?> ParseResults
263263
let project = res.GetProject()
264264
let define = parseResults.OtherFSharpOptions |> Array.choose (fun x ->
265265
if x.StartsWith("--define:") || x.StartsWith("-d:")
266266
then x.[(x.IndexOf(':') + 1)..] |> Some
267267
else None) |> Array.toList
268-
let options = Fable.CompilerOptionsHelper.Make(define=define, ?typedArrays=typedArrays, ?typescript=typescript)
268+
let options =
269+
Fable.CompilerOptionsHelper.Make(define=define,
270+
?eraseUnions=eraseUnions, ?typedArrays=typedArrays, ?typescript=typescript)
269271
let com = CompilerImpl(fileName, project, options, fableLibrary)
270272
let ast =
271273
FSharp2Fable.Compiler.transformFile com

‎src/fable-standalone/test/bench-compiler/Platform.fs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ type CmdLineOptions = {
66
benchmark: bool
77
optimize: bool
88
// sourceMaps: bool
9+
eraseUnions: bool
910
typedArrays: bool
1011
typescript: bool
1112
printAst: bool

‎src/fable-standalone/test/bench-compiler/app.fs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -145,6 +145,7 @@ let parseFiles projectFileName options =
145145

146146
let parseFable (res, fileName) =
147147
fable.CompileToBabelAst(libDir, res, fileName,
148+
eraseUnions = options.eraseUnions,
148149
typedArrays = options.typedArrays,
149150
typescript = options.typescript)
150151

@@ -227,6 +228,7 @@ let run opts projectFileName outDir =
227228
benchmark = opts |> hasFlag "--benchmark"
228229
optimize = opts |> hasFlag "--optimize"
229230
// sourceMaps = opts |> hasFlag "--sourceMaps"
231+
eraseUnions = opts |> hasFlag "--eraseUnions"
230232
typedArrays = opts |> tryFlag "--typedArrays"
231233
|> Option.defaultValue (opts |> hasFlag "--typescript" |> not)
232234
typescript = opts |> hasFlag "--typescript"

‎src/fable-standalone/test/bench-compiler/package.json

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
{
22
"private": true,
3-
"type": "module",
3+
"_type": "module",
44
"scripts": {
55
"build-cli": "dotnet run -c Release -p ../../../Fable.Cli -- bench-compiler.fsproj --outDir out-node",
66
"postbuild-cli": "npm run rollup-bundle",
@@ -44,7 +44,7 @@
4444
"build-tests-dotnet-ts": "dotnet run -c Release ../../../../tests/Main/Fable.Tests.fsproj out-tests --typescript",
4545
"build-tests-dotnet-opt": "dotnet run -c Release ../../../../tests/Main/Fable.Tests.fsproj out-tests --optimize",
4646
"build-tests-node": "node out-node/app.js ../../../../tests/Main/Fable.Tests.fsproj out-tests",
47-
"pretests": "npm run build-tests-dotnet",
47+
"_pretests": "npm run build-tests-dotnet -- --eraseUnions",
4848
"tests": "npm run mocha -- out-tests -r esm --colors",
4949

5050
"tsc": "node ../../../../node_modules/typescript/bin/tsc",

0 commit comments

Comments
 (0)