Skip to content

Commit

Permalink
fix: ignore testers for erased union cases and inline union case test…
Browse files Browse the repository at this point in the history
…ers (fable-compiler#3838)

* Fixed fable-compiler#3658

* Ignore testers for erased union cases

* Inline union case testers
  • Loading branch information
ncave authored Jun 13, 2024
1 parent fd3e8eb commit 7f6c193
Show file tree
Hide file tree
Showing 4 changed files with 74 additions and 22 deletions.
1 change: 1 addition & 0 deletions src/Fable.Cli/CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0

### Fixed

* [All] Ignore testers for erased union cases (#3658) (by @ncave)
* [All] Fixed Fable compiler hanging on some errors (#3842) (by @ncave)
* [JS/TS] Fixed DateTime.MinValue, DateTime.MaxValue (#3836) (by @ncave)

Expand Down
11 changes: 11 additions & 0 deletions src/Fable.Transforms/FSharp2Fable.Util.fs
Original file line number Diff line number Diff line change
Expand Up @@ -1064,6 +1064,17 @@ module Patterns =

let (|MemberFullName|) (memb: FSharpMemberOrFunctionOrValue) = memb.FullName

let (|UnionCaseTesterFor|_|) (memb: FSharpMemberOrFunctionOrValue) =
match memb.DeclaringEntity with
| Some ent when ent.IsFSharpUnion ->
// if memb.IsUnionCaseTester then // TODO: this currently fails, use when fixed
if memb.IsPropertyGetterMethod && memb.LogicalName.StartsWith("get_Is") then
let unionCaseName = memb.LogicalName |> Naming.replacePrefix "get_Is" ""
ent.UnionCases |> Seq.tryFind (fun uc -> uc.Name = unionCaseName)
else
None
| _ -> None

let (|RefType|_|) =
function
| TypeDefinition tdef as t when tdef.TryFullName = Some Types.refCell -> Some t
Expand Down
30 changes: 21 additions & 9 deletions src/Fable.Transforms/FSharp2Fable.fs
Original file line number Diff line number Diff line change
Expand Up @@ -955,8 +955,8 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) appliedGenArgs fs
else
args

match callee with
| Some(CreateEvent(callee, event) as createEvent) ->
match callee, memb with
| Some(CreateEvent(callee, event) as createEvent), _ ->
let! callee = transformExpr com ctx [] callee
let eventType = makeType ctx.GenericArgs createEvent.Type

Expand All @@ -965,7 +965,10 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) appliedGenArgs fs

return makeCallFrom com ctx (makeRangeFrom fsExpr) typ callGenArgs (Some callee) args memb

| callee ->
| Some unionExpr, UnionCaseTesterFor unionCase ->
return! transformUnionCaseTest com ctx (makeRangeFrom fsExpr) unionExpr unionExpr.Type unionCase

| callee, _ ->
let r = makeRangeFrom fsExpr
let! callee = transformExprOpt com ctx callee

Expand Down Expand Up @@ -1474,20 +1477,26 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) appliedGenArgs fs
|> addErrorAndReturnNull com ctx.InlinePath (makeRangeFrom fsExpr)
}

let private isIgnoredNonAttachedMember (meth: FSharpMemberOrFunctionOrValue) =
Option.isSome meth.LiteralValue
|| meth.Attributes
let private isIgnoredNonAttachedMember (memb: FSharpMemberOrFunctionOrValue) =
Option.isSome memb.LiteralValue
|| memb.Attributes
|> Seq.exists (fun att ->
match att.AttributeType.TryFullName with
| Some(Atts.global_ | Naming.StartsWith Atts.import _ | Naming.StartsWith Atts.emit _) -> true
| _ -> false
)
|| (
match meth.DeclaringEntity with
match memb.DeclaringEntity with
| Some ent -> isGlobalOrImportedFSharpEntity ent
| None -> false
)

let private isUnionCaseTester (memb: FSharpMemberOrFunctionOrValue) =
// memb.IsUnionCaseTester // TODO: this currently fails, use when fixed
match memb with
| UnionCaseTesterFor _ -> true
| _ -> false

let private isCompilerGenerated (memb: FSharpMemberOrFunctionOrValue) (args: FSharpMemberOrFunctionOrValue list list) =
memb.IsCompilerGenerated
&& memb.IsInstanceMember
Expand Down Expand Up @@ -1905,6 +1914,9 @@ let private transformMemberDecl
[]
elif memb.IsImplicitConstructor then
transformPrimaryConstructor com ctx memb args body
// ignore union case testers as they will be inlined
elif isUnionCaseTester memb then
[]
// Ignore members generated by the F# compiler (for comparison and equality)
elif isCompilerGenerated memb args then
[]
Expand Down Expand Up @@ -2047,8 +2059,8 @@ let rec private transformDeclarations (com: FableCompiler) ctx fsDecls =
}
]
| sub -> transformDeclarations com ctx sub
| FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(meth, args, body) ->
transformMemberDecl com ctx meth args body
| FSharpImplementationFileDeclaration.MemberOrFunctionOrValue(memb, args, body) ->
transformMemberDecl com ctx memb args body
| FSharpImplementationFileDeclaration.InitAction fe ->
let ctx = { ctx with UsedNamesInDeclarationScope = HashSet() }
let e = transformExpr com ctx [] fe |> run
Expand Down
54 changes: 41 additions & 13 deletions src/Fable.Transforms/Rust/Fable2Rust.fs
Original file line number Diff line number Diff line change
Expand Up @@ -2732,6 +2732,7 @@ module Util =
let guardExpr =
match guard with
| Fable.Test(expr, Fable.TypeTest typ, r) -> transformTypeTest com ctx r true typ expr
| Fable.Test(expr, Fable.UnionCaseTest tag, r) -> transformUnionCaseTest com ctx r tag expr
| _ -> transformExpr com ctx guard

let thenExpr = transformLeaveContext com ctx None thenBody
Expand Down Expand Up @@ -2846,6 +2847,38 @@ module Util =
mkLetExpr pat downcastExpr
| _ -> makeLibCall com ctx genArgsOpt "Native" "type_test" [ expr ]

let transformUnionCaseTest (com: IRustCompiler) ctx range tag (fableExpr: Fable.Expr) : Rust.Expr =
match fableExpr.Type with
| Fable.DeclaredType(entRef, genArgs) ->
let ent = com.GetEntity(entRef)
assert (ent.IsFSharpUnion)
// let genArgsOpt = transformGenArgs com ctx genArgs // TODO:
let unionCase = ent.UnionCases |> List.item tag

let fields =
match fableExpr with
| Fable.IdentExpr ident ->
unionCase.UnionCaseFields
|> List.mapi (fun i _field ->
let fieldName = $"{ident.Name}_{tag}_{i}"
makeFullNameIdentPat fieldName
)
| _ ->
if List.isEmpty unionCase.UnionCaseFields then
[]
else
[ WILD_PAT ]

let unionCaseName = getUnionCaseName com ctx entRef unionCase
let pat = makeUnionCasePat unionCaseName fields

let expr =
fableExpr
|> prepareRefForPatternMatch com ctx fableExpr.Type (tryGetIdentName fableExpr)

mkLetExpr pat expr
| _ -> failwith "Should not happen"

let transformTest (com: IRustCompiler) ctx range kind (fableExpr: Fable.Expr) : Rust.Expr =
match kind with
| Fable.TypeTest typ -> transformTypeTest com ctx range false typ fableExpr
Expand Down Expand Up @@ -2874,18 +2907,10 @@ module Util =
let unionCase = ent.UnionCases |> List.item tag

let fields =
match fableExpr with
| Fable.IdentExpr ident ->
unionCase.UnionCaseFields
|> List.mapi (fun i _field ->
let fieldName = $"{ident.Name}_{tag}_{i}"
makeFullNameIdentPat fieldName
)
| _ ->
if List.isEmpty unionCase.UnionCaseFields then
[]
else
[ WILD_PAT ]
if List.isEmpty unionCase.UnionCaseFields then
[]
else
[ WILD_PAT ]

let unionCaseName = getUnionCaseName com ctx entRef unionCase
let pat = makeUnionCasePat unionCaseName fields
Expand All @@ -2894,7 +2919,10 @@ module Util =
fableExpr
|> prepareRefForPatternMatch com ctx fableExpr.Type (tryGetIdentName fableExpr)

mkLetExpr pat expr
let guardExpr = mkLetExpr pat expr
let thenExpr = mkBoolLitExpr true
let elseExpr = mkBoolLitExpr false
mkIfThenElseExpr guardExpr thenExpr elseExpr
| _ -> failwith "Should not happen"

let transformSwitch (com: IRustCompiler) ctx (evalExpr: Fable.Expr) cases defaultCase targets : Rust.Expr =
Expand Down

0 comments on commit 7f6c193

Please sign in to comment.