diff --git a/src/Fable.Transforms/FSharp2Fable.fs b/src/Fable.Transforms/FSharp2Fable.fs index 17426e8edb..23a26e23c9 100644 --- a/src/Fable.Transforms/FSharp2Fable.fs +++ b/src/Fable.Transforms/FSharp2Fable.fs @@ -18,6 +18,12 @@ open Util let inline private transformExprList com ctx xs = trampolineListMap (transformExpr com ctx) xs let inline private transformExprOpt com ctx opt = trampolineOptionMap (transformExpr com ctx) opt +let private transformSequential com ctx xs = + trampoline { + let! xs = trampolineListMap (transformExpr com ctx) xs + return Fable.Sequential xs + } + let private transformBaseConsCall com ctx r (baseEnt: FSharpEntity) (baseCons: FSharpMemberOrFunctionOrValue) genArgs baseArgs = let baseEnt = FsEnt baseEnt let argTypes = lazy getArgTypes com baseCons @@ -815,24 +821,32 @@ let private transformExpr (com: IFableCompiler) (ctx: Context) fsExpr = return makeCallFrom com ctx (makeRangeFrom fsExpr) typ genArgs None args memb | BasicPatterns.Sequential (first, second) -> - let exprs = - match ctx.CaptureBaseConsCall with - | Some(baseEnt, captureBaseCall) -> - match first with - | ConstructorCall(call, genArgs, args) - // This pattern occurs in constructors that define a this value: `type C() as this` - // We're discarding the bound `this` value, it "shouldn't" be used in the base constructor arguments - | BasicPatterns.Let(_, (ConstructorCall(call, genArgs, args))) -> - match call.DeclaringEntity with - | Some ent when ent = baseEnt -> - let r = makeRangeFrom first - transformBaseConsCall com ctx r baseEnt call genArgs args |> captureBaseCall - [second] - | _ -> [first; second] - | _ -> [first; second] - | _ -> [first; second] - let! exprs = transformExprList com ctx exprs - return Fable.Sequential exprs + match ctx.CaptureBaseConsCall with + | Some(baseEnt, captureBaseCall) -> + match first with + | ConstructorCall(call, genArgs, args) + // This pattern occurs in constructors that define a this value: `type C() as this` + // We're discarding the bound `this` value, it "shouldn't" be used in the base constructor arguments + | BasicPatterns.Let(_, (ConstructorCall(call, genArgs, args))) -> + match call.DeclaringEntity with + | Some ent when ent = baseEnt -> + let r = makeRangeFrom first + transformBaseConsCall com ctx r baseEnt call genArgs args |> captureBaseCall + return! transformExpr com ctx second + | _ -> return! transformSequential com ctx [first; second] + | _ -> return! transformSequential com ctx [first; second] + | None -> + match first, second with + | ConstructorCall(baseCall, _, baseArgs), BasicPatterns.NewRecord(consType, consArgs) + when (match baseCall.DeclaringEntity, consType.BaseType with + | Some baseCallEntity, Some(TypeDefinition consBaseEntity) -> baseCallEntity = consBaseEntity + | _ -> false) -> + let r = makeRangeFrom fsExpr + let! baseArgs = transformExprList com ctx baseArgs + let! consArgs = transformExprList com ctx consArgs + let genArgs = makeGenArgs ctx.GenericArgs (getGenericArguments consType) + return Fable.NewRecord(baseArgs @ consArgs, FsEnt.Ref consType.TypeDefinition, genArgs) |> makeValue r + | _ -> return! transformSequential com ctx [first; second] | BasicPatterns.NewRecord(fsType, argExprs) -> let r = makeRangeFrom fsExpr diff --git a/src/Fable.Transforms/Fable2Babel.fs b/src/Fable.Transforms/Fable2Babel.fs index 66cb30e74d..f80c2acddf 100644 --- a/src/Fable.Transforms/Fable2Babel.fs +++ b/src/Fable.Transforms/Fable2Babel.fs @@ -819,7 +819,7 @@ module Util = getExpr r expr (Expression.stringLiteral("tag")) /// Wrap int expressions with `| 0` to help optimization of JS VMs - let wrapIntExpression typ (e: Expression) = + let wrapIfIntExpression typ (e: Expression) = match e, typ with | Literal(NumericLiteral(_)), _ -> e // TODO: Unsigned ints seem to cause problems, should we check only Int32 here? @@ -1071,7 +1071,7 @@ module Util = |> extractBaseExprFromBaseCall com ctx None |> Option.map (fun (baseExpr, baseArgs) -> let consBody = BlockStatement([|callSuperAsStatement baseArgs|]) - let cons = makeClassConstructor [||] consBody + let cons = makeClassConstructor [||] consBody Some baseExpr, cons::classMembers ) |> Option.defaultValue (None, classMembers) @@ -1099,7 +1099,7 @@ module Util = match strategy with | None | Some ReturnUnit -> ExpressionStatement(babelExpr) // TODO: Where to put these int wrappings? Add them also for function arguments? - | Some Return -> Statement.returnStatement(wrapIntExpression t babelExpr) + | Some Return -> Statement.returnStatement(wrapIfIntExpression t babelExpr) | Some(Assign left) -> ExpressionStatement(assign None left babelExpr) | Some(Target left) -> ExpressionStatement(assign None (left |> Expression.Identifier) babelExpr) @@ -1233,7 +1233,7 @@ module Util = let transformSet (com: IBabelCompiler) ctx range fableExpr (value: Fable.Expr) kind = let expr = com.TransformAsExpr(ctx, fableExpr) - let value = com.TransformAsExpr(ctx, value) |> wrapIntExpression value.Type + let value = com.TransformAsExpr(ctx, value) |> wrapIfIntExpression value.Type let ret = match kind with | None -> expr @@ -1251,7 +1251,7 @@ module Util = if var.IsMutable then com.TransformAsExpr(ctx, value) else - com.TransformAsExpr(ctx, value) |> wrapIntExpression value.Type + com.TransformAsExpr(ctx, value) |> wrapIfIntExpression value.Type let transformBindingAsExpr (com: IBabelCompiler) ctx (var: Fable.Ident) (value: Fable.Expr) = transformBindingExprBody com ctx var value @@ -1943,25 +1943,31 @@ module Util = let transformClassWithCompilerGeneratedConstructor (com: IBabelCompiler) ctx (ent: Fable.Entity) (entName: string) classMembers = let fieldIds = getEntityFieldsAsIdents com ent - let args = fieldIds |> Array.map identAsExpr - let baseExpr = + let baseArgs, baseExpr = if ent.IsFSharpExceptionDeclaration - then libValue com ctx "Types" "FSharpException" |> Some + then [], libValue com ctx "Types" "FSharpException" |> Some elif ent.IsFSharpRecord || ent.IsValueType - then libValue com ctx "Types" "Record" |> Some - else None + then [], libValue com ctx "Types" "Record" |> Some + else + match ent.BaseType with + | Some b -> + let baseEntity = b.Entity |> com.GetEntity + // TODO: Get base constructor arguments + [], Some(jsConstructor com ctx baseEntity) + | None -> [], None let body = BlockStatement([| if Option.isSome baseExpr then - yield callSuperAsStatement [] + yield baseArgs |> List.map identAsExpr |> callSuperAsStatement yield! ent.FSharpFields |> Seq.mapi (fun i field -> let left = get None thisExpr field.Name - let right = wrapIntExpression field.FieldType args.[i] + let right = identAsExpr fieldIds.[i] |> wrapIfIntExpression field.FieldType assign None left right |> ExpressionStatement) |> Seq.toArray |]) - let typedPattern x = typedIdent com ctx x - let args = fieldIds |> Array.map (typedPattern >> Pattern.Identifier) + let args = + Array.append (List.toArray baseArgs) fieldIds + |> Array.map (fun x -> typedIdent com ctx x |> Pattern.Identifier) declareType com ctx ent entName args body baseExpr classMembers let transformClassWithImplicitConstructor (com: IBabelCompiler) ctx (classDecl: Fable.ClassDecl) classMembers (cons: Fable.MemberDecl) = diff --git a/src/quicktest/QuickTest.fs b/src/quicktest/QuickTest.fs index a61381c5c7..59ed723512 100644 --- a/src/quicktest/QuickTest.fs +++ b/src/quicktest/QuickTest.fs @@ -66,3 +66,17 @@ let measureTime (f: unit -> unit) = emitJsStatement () """ // to Fable.Tests project. For example: // testCase "Addition works" <| fun () -> // 2 + 2 |> equal 4 +type Node = + val X: int + new (x: int) = { X = x } + +type Node2(x: int, ?j: int) = //, ?j: int) = + member val X = x + member val J = defaultArg j 3 + // new (x: int) = { X = x } + +type Leaf = + inherit Node2 + val Y: string + new (y: string, x) = + { inherit Node2(x + 5); Y = y + "a" }