Skip to content

Commit

Permalink
Added support for erased records
Browse files Browse the repository at this point in the history
  • Loading branch information
ncave committed Nov 30, 2020
1 parent 2f55c5a commit 52922f1
Show file tree
Hide file tree
Showing 12 changed files with 102 additions and 31 deletions.
4 changes: 2 additions & 2 deletions .vscode/launch.json
Original file line number Diff line number Diff line change
Expand Up @@ -65,8 +65,8 @@
"name": "Run bench-compiler (.NET)",
"program": "${workspaceFolder}/src/fable-standalone/test/bench-compiler/bin/Debug/netcoreapp3.1/bench-compiler.dll",
// "args": ["${workspaceRoot}/tests/Main/Fable.Tests.fsproj", "out-tests"],
// "args": ["${workspaceRoot}/../fable-test/fable-test.fsproj", "out-test", "--typescript"],
"args": ["${workspaceRoot}/src/fable-library/Fable.Library.fsproj", "out-lib", "--typescript"],
"args": ["${workspaceRoot}/../fable-test/fable-test.fsproj", "out-test", "--typescript"],
// "args": ["${workspaceRoot}/src/fable-library/Fable.Library.fsproj", "out-lib", "--typescript"],
"cwd": "${workspaceFolder}/src/fable-standalone/test/bench-compiler"
},
{
Expand Down
1 change: 1 addition & 0 deletions src/Fable.AST/Fable.fs
Original file line number Diff line number Diff line change
Expand Up @@ -266,6 +266,7 @@ type KeyKind =
type GetKind =
| ByKey of KeyKind
| TupleIndex of int
| FieldIndex of string * int
| UnionField of index: int * fieldType: Type
| UnionTag
| ListHead
Expand Down
7 changes: 5 additions & 2 deletions src/Fable.Transforms/FSharp2Fable.Util.fs
Original file line number Diff line number Diff line change
Expand Up @@ -433,6 +433,10 @@ module Helpers =
let makeRangeFrom (fsExpr: FSharpExpr) =
Some (makeRange fsExpr.Range)

let isErasedRecord (com: Compiler) (t: FSharpType) =
// TODO: check for custom equality or comparison
com.Options.EraseUnions && t.HasTypeDefinition && t.TypeDefinition.IsFSharpRecord

let unionCaseTag (ent: FSharpEntity) (unionCase: FSharpUnionCase) =
try
ent.UnionCases |> Seq.findIndex (fun uci -> unionCase.Name = uci.Name)
Expand Down Expand Up @@ -697,8 +701,7 @@ module Patterns =
match tryDefinition typ with
| None -> failwith "Union without definition"
| Some(tdef, fullName) ->
let fullName = defaultArg fullName tdef.CompiledName
match fullName with
match defaultArg fullName tdef.CompiledName with
| Types.valueOption
| Types.option -> OptionUnion typ.GenericArguments.[0]
| Types.list -> ListUnion typ.GenericArguments.[0]
Expand Down
38 changes: 28 additions & 10 deletions src/Fable.Transforms/FSharp2Fable.fs
Original file line number Diff line number Diff line change
Expand Up @@ -646,21 +646,30 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) fsExpr =

// Getters and Setters
| BasicPatterns.AnonRecordGet(callee, calleeType, fieldIndex) ->
let r = makeRangeFrom fsExpr
let! callee = transformExpr com ctx callee
let fieldName = calleeType.AnonRecordTypeDetails.SortedFieldNames.[fieldIndex]
let typ = makeType ctx.GenericArgs fsExpr.Type
let key = FsField(fieldName, lazy typ) :> Fable.Field |> Fable.FieldKey
return Fable.Get(callee, Fable.ByKey key, typ, makeRangeFrom fsExpr)
let fieldName = calleeType.AnonRecordTypeDetails.SortedFieldNames.[fieldIndex]
if isErasedRecord com calleeType then
return Fable.Get(callee, Fable.FieldIndex(fieldName, fieldIndex), typ, r)
else
let key = FsField(fieldName, lazy typ) :> Fable.Field |> Fable.FieldKey
return Fable.Get(callee, Fable.ByKey key, typ, r)

| BasicPatterns.FSharpFieldGet(callee, calleeType, field) ->
let r = makeRangeFrom fsExpr
let! callee = transformExprOpt com ctx callee
let callee =
match callee with
| Some callee -> callee
| None -> entityRef com (FsEnt calleeType.TypeDefinition)
let key = FsField field :> Fable.Field |> Fable.FieldKey
let typ = makeType ctx.GenericArgs fsExpr.Type
return Fable.Get(callee, Fable.ByKey key, typ, makeRangeFrom fsExpr)
if isErasedRecord com calleeType then
let index = calleeType.TypeDefinition.FSharpFields |> Seq.findIndex (fun x -> x.Name = field.Name)
return Fable.Get(callee, Fable.FieldIndex(field.Name, index + 1), typ, r)
else
let key = FsField field :> Fable.Field |> Fable.FieldKey
return Fable.Get(callee, Fable.ByKey key, typ, r)

| BasicPatterns.TupleGet(_tupleType, tupleElemIndex, tupleExpr) ->
let! tupleExpr = transformExpr com ctx tupleExpr
Expand Down Expand Up @@ -778,15 +787,24 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) fsExpr =
return Fable.Sequential exprs

| BasicPatterns.NewRecord(fsType, argExprs) ->
let r = makeRangeFrom fsExpr
let! argExprs = transformExprList com ctx argExprs
let genArgs = makeGenArgs ctx.GenericArgs (getGenericArguments fsType)
return Fable.NewRecord(argExprs, FsEnt.Ref fsType.TypeDefinition, genArgs) |> makeValue (makeRangeFrom fsExpr)
if isErasedRecord com fsType then
let recordName = (makeStrConst (getFsTypeFullName fsType))
return recordName::argExprs |> Fable.NewTuple |> makeValue r
else
let genArgs = makeGenArgs ctx.GenericArgs (getGenericArguments fsType)
return Fable.NewRecord(argExprs, FsEnt.Ref fsType.TypeDefinition, genArgs) |> makeValue r

| BasicPatterns.NewAnonRecord(fsType, argExprs) ->
let r = makeRangeFrom fsExpr
let! argExprs = transformExprList com ctx argExprs
let fieldNames = fsType.AnonRecordTypeDetails.SortedFieldNames
let genArgs = makeGenArgs ctx.GenericArgs (getGenericArguments fsType)
return Fable.NewAnonymousRecord(argExprs, fieldNames, genArgs) |> makeValue (makeRangeFrom fsExpr)
if isErasedRecord com fsType then
return argExprs |> Fable.NewTuple |> makeValue r
else
let fieldNames = fsType.AnonRecordTypeDetails.SortedFieldNames
let genArgs = makeGenArgs ctx.GenericArgs (getGenericArguments fsType)
return Fable.NewAnonymousRecord(argExprs, fieldNames, genArgs) |> makeValue r

| BasicPatterns.NewUnionCase(fsType, unionCase, argExprs) ->
let! argExprs = transformExprList com ctx argExprs
Expand Down
1 change: 1 addition & 0 deletions src/Fable.Transforms/Fable2Babel.fs
Original file line number Diff line number Diff line change
Expand Up @@ -1208,6 +1208,7 @@ module Util =
| Fable.ListTail ->
get range (com.TransformAsExpr(ctx, fableExpr)) "tail"

| Fable.FieldIndex (_, index)
| Fable.TupleIndex index ->
match fableExpr with
// TODO: Check the erased expressions don't have side effects?
Expand Down
8 changes: 4 additions & 4 deletions src/Fable.Transforms/FableTransforms.fs
Original file line number Diff line number Diff line change
Expand Up @@ -59,8 +59,8 @@ let visit f e =
Operation(Logical(op, f left, f right), t, r)
| Get(e, kind, t, r) ->
match kind with
| ListHead | ListTail | OptionValue | TupleIndex _ | UnionTag
| UnionField _ | ByKey(FieldKey _) -> Get(f e, kind, t, r)
| ListHead | ListTail | OptionValue | TupleIndex _ | FieldIndex _
| UnionTag | UnionField _ | ByKey(FieldKey _) -> Get(f e, kind, t, r)
| ByKey(ExprKey e2) -> Get(f e, ByKey(ExprKey(f e2)), t, r)
| Sequential exprs -> Sequential(List.map f exprs)
| Let(ident, value, body) -> Let(ident, f value, f body)
Expand Down Expand Up @@ -131,8 +131,8 @@ let getSubExpressions = function
| Logical(_, left, right) -> [left; right]
| Get(e, kind, _, _) ->
match kind with
| ListHead | ListTail | OptionValue | TupleIndex _ | UnionTag
| UnionField _ | ByKey(FieldKey _) -> [e]
| ListHead | ListTail | OptionValue | TupleIndex _ | FieldIndex _
| UnionTag | UnionField _ | ByKey(FieldKey _) -> [e]
| ByKey(ExprKey e2) -> [e; e2]
| Sequential exprs -> exprs
| Let(_, value, body) -> [value; body]
Expand Down
57 changes: 49 additions & 8 deletions src/Fable.Transforms/Replacements.fs
Original file line number Diff line number Diff line change
Expand Up @@ -217,6 +217,7 @@ let (|Nameof|_|) com ctx = function
| IdentExpr ident -> Some ident.DisplayName
| Get(_, ByKey(ExprKey(StringConst prop)), _, _) -> Some prop
| Get(_, ByKey(FieldKey fi), _, _) -> Some fi.Name
| Get(_, FieldIndex(fieldName, _), _, _) -> Some fieldName
| NestedLambda(args, Call(IdentExpr ident, info, _, _), None) ->
if List.sameLength args info.Args && List.zip args info.Args |> List.forall (fun (a1, a2) ->
match a2 with IdentExpr id2 -> a1.Name = id2.Name | _ -> false)
Expand Down Expand Up @@ -695,6 +696,50 @@ let isCompatibleWithJsComparison = function
// * `.GetHashCode` called directly defaults to identity hash (for reference types except string) if not implemented.
// * `LanguagePrimitive.PhysicalHash` creates an identity hash no matter whether GetHashCode is implemented or not.

let getEntityHashMethod (com: ICompiler) (ent: Entity) =
if (ent.IsFSharpUnion || ent.IsFSharpRecord) then
if com.Options.EraseUnions
then "Util", "structuralHash"
else "Util", "hashSafe"
elif ent.IsValueType
then "Util", "hashSafe"
else "Util", "identityHash"

let getEntityEqualsMethod (com: ICompiler) (ent: Entity) =
if (ent.IsFSharpUnion || ent.IsFSharpRecord) then
if com.Options.EraseUnions
then "Util", "equals"
else "Util", "equalsSafe"
elif ent.IsValueType
then "Util", "equalsSafe"
else "Util", "equals"

let getEntityCompareMethod (com: ICompiler) (ent: Entity) =
if (ent.IsFSharpUnion || ent.IsFSharpRecord) then
if com.Options.EraseUnions
then "Util", "compare"
else "Util", "compareSafe"
elif ent.IsValueType
then "Util", "compareSafe"
else "Util", "compare"

let identityHashMethod (com: ICompiler) = function
| Boolean | Char | String | Number _ | Enum _ | Option _ | Tuple _ | List _
| Builtin (BclInt64 | BclUInt64 | BclDecimal | BclBigInt)
| Builtin (BclGuid | BclTimeSpan | BclDateTime | BclDateTimeOffset)
| Builtin (FSharpSet _ | FSharpMap _ | FSharpChoice _ | FSharpResult _) ->
"Util", "structuralHash"
| DeclaredType(ent, _) -> com.GetEntity(ent) |> getEntityHashMethod com
| _ -> "Util", "identityHash"

let structuralHashMethod (com: ICompiler) = function
| MetaType -> "Reflection", "getHashCode"
| DeclaredType(ent, _) ->
let ent = com.GetEntity(ent)
if not ent.IsInterface then getEntityHashMethod com ent
else "Util", "structuralHash"
| _ -> "Util", "structuralHash"

let identityHash com r (arg: Expr) =
let methodName =
match arg.Type with
Expand Down Expand Up @@ -747,10 +792,8 @@ let rec equals (com: ICompiler) ctx r equal (left: Expr) (right: Expr) =
Helper.LibCall(com, coreModFor bt, "equals", Boolean, [left; right], ?loc=r) |> is equal
| DeclaredType(ent, _) ->
let ent = com.GetEntity(ent)
if ent.IsFSharpUnion || ent.IsFSharpRecord || ent.IsValueType then
Helper.LibCall(com, "Util", "equalsSafe", Boolean, [left; right], ?loc=r) |> is equal
else
Helper.LibCall(com, "Util", "equals", Boolean, [left; right], ?loc=r) |> is equal
let moduleName, methodName = getEntityEqualsMethod com ent
Helper.LibCall(com, moduleName, methodName, Boolean, [left; right], ?loc=r) |> is equal
| Array t ->
let f = makeComparerFunction com ctx t
Helper.LibCall(com, "Array", "equalsWith", Boolean, [f; left; right], ?loc=r) |> is equal
Expand All @@ -775,10 +818,8 @@ and compare (com: ICompiler) ctx r (left: Expr) (right: Expr) =
Helper.LibCall(com, coreModFor bt, "compare", Number Int32, [left; right], ?loc=r)
| DeclaredType(ent, _) ->
let ent = com.GetEntity(ent)
if ent.IsFSharpUnion || ent.IsFSharpRecord || ent.IsValueType then
Helper.LibCall(com, "Util", "compareSafe", Number Int32, [left; right], ?loc=r)
else
Helper.LibCall(com, "Util", "compare", Number Int32, [left; right], ?loc=r)
let moduleName, methodName = getEntityCompareMethod com ent
Helper.LibCall(com, moduleName, methodName, Number Int32, [left; right], ?loc=r)
| Array t ->
let f = makeComparerFunction com ctx t
Helper.LibCall(com, "Array", "compareWith", Number Int32, [f; left; right], ?loc=r)
Expand Down
4 changes: 3 additions & 1 deletion src/fable-standalone/src/Interfaces.fs
Original file line number Diff line number Diff line change
Expand Up @@ -64,7 +64,9 @@ type IFableManager =
abstract GetToolTipText: parseResults: IParseResults * line: int * col: int * lineText: string -> string[]
abstract GetCompletionsAtLocation: parseResults: IParseResults * line: int * col: int * lineText: string -> Completion[]
abstract CompileToBabelAst: fableLibrary: string * parseResults: IParseResults * fileName: string
* ?eraseUnions: bool
* ?typedArrays: bool
* ?typescript: bool -> IBabelResult
* ?typescript: bool
-> IBabelResult
abstract PrintBabelAst: babelResult: IBabelResult * IWriter -> Async<unit>
abstract FSharpAstToString: parseResults: IParseResults * fileName: string -> string
6 changes: 4 additions & 2 deletions src/fable-standalone/src/Main.fs
Original file line number Diff line number Diff line change
Expand Up @@ -258,14 +258,16 @@ let init () =
getCompletionsAtLocation res line col lineText

member __.CompileToBabelAst(fableLibrary:string, parseResults:IParseResults, fileName:string,
?typedArrays, ?typescript) =
?eraseUnions, ?typedArrays, ?typescript) =
let res = parseResults :?> ParseResults
let project = res.GetProject()
let define = parseResults.OtherFSharpOptions |> Array.choose (fun x ->
if x.StartsWith("--define:") || x.StartsWith("-d:")
then x.[(x.IndexOf(':') + 1)..] |> Some
else None) |> Array.toList
let options = Fable.CompilerOptionsHelper.Make(define=define, ?typedArrays=typedArrays, ?typescript=typescript)
let options =
Fable.CompilerOptionsHelper.Make(define=define,
?eraseUnions=eraseUnions, ?typedArrays=typedArrays, ?typescript=typescript)
let com = CompilerImpl(fileName, project, options, fableLibrary)
let ast =
FSharp2Fable.Compiler.transformFile com
Expand Down
1 change: 1 addition & 0 deletions src/fable-standalone/test/bench-compiler/Platform.fs
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,7 @@ type CmdLineOptions = {
benchmark: bool
optimize: bool
// sourceMaps: bool
eraseUnions: bool
typedArrays: bool
typescript: bool
printAst: bool
Expand Down
2 changes: 2 additions & 0 deletions src/fable-standalone/test/bench-compiler/app.fs
Original file line number Diff line number Diff line change
Expand Up @@ -145,6 +145,7 @@ let parseFiles projectFileName options =

let parseFable (res, fileName) =
fable.CompileToBabelAst(libDir, res, fileName,
eraseUnions = options.eraseUnions,
typedArrays = options.typedArrays,
typescript = options.typescript)

Expand Down Expand Up @@ -227,6 +228,7 @@ let run opts projectFileName outDir =
benchmark = opts |> hasFlag "--benchmark"
optimize = opts |> hasFlag "--optimize"
// sourceMaps = opts |> hasFlag "--sourceMaps"
eraseUnions = opts |> hasFlag "--eraseUnions"
typedArrays = opts |> tryFlag "--typedArrays"
|> Option.defaultValue (opts |> hasFlag "--typescript" |> not)
typescript = opts |> hasFlag "--typescript"
Expand Down
4 changes: 2 additions & 2 deletions src/fable-standalone/test/bench-compiler/package.json
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
{
"private": true,
"type": "module",
"_type": "module",
"scripts": {
"build-cli": "dotnet run -c Release -p ../../../Fable.Cli -- bench-compiler.fsproj --outDir out-node",
"postbuild-cli": "npm run rollup-bundle",
Expand Down Expand Up @@ -44,7 +44,7 @@
"build-tests-dotnet-ts": "dotnet run -c Release ../../../../tests/Main/Fable.Tests.fsproj out-tests --typescript",
"build-tests-dotnet-opt": "dotnet run -c Release ../../../../tests/Main/Fable.Tests.fsproj out-tests --optimize",
"build-tests-node": "node out-node/app.js ../../../../tests/Main/Fable.Tests.fsproj out-tests",
"pretests": "npm run build-tests-dotnet",
"_pretests": "npm run build-tests-dotnet -- --eraseUnions",
"tests": "npm run mocha -- out-tests -r esm --colors",

"tsc": "node ../../../../node_modules/typescript/bin/tsc",
Expand Down

0 comments on commit 52922f1

Please sign in to comment.