Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merge master to fsharp5 #6618

Merged
1 commit merged into from
Apr 23, 2019
Merged

Merge master to fsharp5 #6618

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
38 changes: 25 additions & 13 deletions src/fsharp/TastOps.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6492,8 +6492,6 @@ let mkRefTupledNoTypes g m args = mkRefTupled g m args (List.map (tyOfExpr g) ar

let mkRefTupledVars g m vs = mkRefTupled g m (List.map (exprForVal m) vs) (typesOfVals vs)

let mkAnonRecd (_g: TcGlobals) m anonInfo es tys = Expr.Op (TOp.AnonRecd anonInfo,tys,es,m)

//--------------------------------------------------------------------------
// Permute expressions
//--------------------------------------------------------------------------
Expand Down Expand Up @@ -6554,21 +6552,35 @@ let permuteExprList (sigma: int[]) (exprs: Expr list) (ty: TType list) (names: s
/// let sigma = Array.map #Index ()
/// However the presence of static fields means .Index may index into a non-compact set of instance field indexes.
/// We still need to sort by index.
let mkRecordExpr g (lnk, tcref, tinst, rfrefs: RecdFieldRef list, args, m) =
let mkRecordExpr g (lnk, tcref, tinst, unsortedRecdFields: RecdFieldRef list, unsortedFieldExprs, m) =
// Remove any abbreviations
let tcref, tinst = destAppTy g (mkAppTy tcref tinst)

let rfrefsArray = rfrefs |> List.indexed |> Array.ofList
rfrefsArray |> Array.sortInPlaceBy (fun (_, r) -> r.Index)
let sigma = Array.create rfrefsArray.Length -1
Array.iteri (fun j (i, _) ->
if sigma.[i] <> -1 then error(InternalError("bad permutation", m))
sigma.[i] <- j) rfrefsArray
let sortedRecdFields = unsortedRecdFields |> List.indexed |> Array.ofList |> Array.sortBy (fun (_, r) -> r.Index)
let sigma = Array.create sortedRecdFields.Length -1
sortedRecdFields |> Array.iteri (fun sortedIdx (unsortedIdx, _) ->
if sigma.[unsortedIdx] <> -1 then error(InternalError("bad permutation", m))
sigma.[unsortedIdx] <- sortedIdx)

let unsortedArgTys = unsortedRecdFields |> List.map (fun rfref -> actualTyOfRecdFieldRef rfref tinst)
let unsortedArgNames = unsortedRecdFields |> List.map (fun rfref -> rfref.FieldName)
let unsortedArgBinds, sortedArgExprs = permuteExprList sigma unsortedFieldExprs unsortedArgTys unsortedArgNames
let core = Expr.Op (TOp.Recd (lnk, tcref), tinst, sortedArgExprs, m)
mkLetsBind m unsortedArgBinds core

let mkAnonRecd (_g: TcGlobals) m (anonInfo: AnonRecdTypeInfo) (unsortedIds: Ident[]) (unsortedFieldExprs: Expr list) unsortedArgTys =
let sortedRecdFields = unsortedFieldExprs |> List.indexed |> Array.ofList |> Array.sortBy (fun (i,_) -> unsortedIds.[i].idText)
let sortedArgTys = unsortedArgTys |> List.indexed |> List.sortBy (fun (i,_) -> unsortedIds.[i].idText) |> List.map snd

let sigma = Array.create sortedRecdFields.Length -1
sortedRecdFields |> Array.iteri (fun sortedIdx (unsortedIdx, _) ->
if sigma.[unsortedIdx] <> -1 then error(InternalError("bad permutation", m))
sigma.[unsortedIdx] <- sortedIdx)

let argTys = List.map (fun rfref -> actualTyOfRecdFieldRef rfref tinst) rfrefs
let names = rfrefs |> List.map (fun rfref -> rfref.FieldName)
let binds, args = permuteExprList sigma args argTys names
mkLetsBind m binds (Expr.Op (TOp.Recd (lnk, tcref), tinst, args, m))
let unsortedArgNames = unsortedIds |> Array.toList |> List.map (fun id -> id.idText)
let unsortedArgBinds, sortedArgExprs = permuteExprList sigma unsortedFieldExprs unsortedArgTys unsortedArgNames
let core = Expr.Op (TOp.AnonRecd anonInfo, sortedArgTys, sortedArgExprs, m)
mkLetsBind m unsortedArgBinds core

//-------------------------------------------------------------------------
// List builders
Expand Down
2 changes: 1 addition & 1 deletion src/fsharp/TastOps.fsi
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2120,7 +2120,7 @@ val mkMethodTy : TcGlobals -> TType list list -> TType -> TType

val mkAnyAnonRecdTy : TcGlobals -> AnonRecdTypeInfo -> TType list -> TType

val mkAnonRecd : TcGlobals -> range -> AnonRecdTypeInfo -> Exprs -> TType list -> Expr
val mkAnonRecd : TcGlobals -> range -> AnonRecdTypeInfo -> Ident[] -> Exprs -> TType list -> Expr

val AdjustValForExpectedArity : TcGlobals -> range -> ValRef -> ValUseFlag -> ValReprInfo -> Expr * TType

Expand Down
116 changes: 79 additions & 37 deletions src/fsharp/TypeChecker.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4673,11 +4673,11 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: SyntacticUnscope
| SynType.AnonRecd(isStruct, args,m) ->
let tupInfo = mkTupInfo isStruct
let args',tpenv = TcTypesAsTuple cenv newOk checkCxs occ env tpenv (args |> List.map snd |> List.map (fun x -> (false,x))) m
let unsortedIds = args |> List.map fst |> List.toArray
let anonInfo = AnonRecdTypeInfo.Create(cenv.topCcu, tupInfo, unsortedIds)
let unsortedFieldIds = args |> List.map fst |> List.toArray
let anonInfo = AnonRecdTypeInfo.Create(cenv.topCcu, tupInfo, unsortedFieldIds)
// Sort into canonical order
let sortedArgTys, sortedCheckedArgTys = List.zip args args' |> List.indexed |> List.sortBy (fun (i,_) -> unsortedIds.[i].idText) |> List.map snd |> List.unzip
sortedArgTys |> List.iteri (fun i (x,_) ->
let sortedFieldTys, sortedCheckedArgTys = List.zip args args' |> List.indexed |> List.sortBy (fun (i,_) -> unsortedFieldIds.[i].idText) |> List.map snd |> List.unzip
sortedFieldTys |> List.iteri (fun i (x,_) ->
let item = Item.AnonRecdField(anonInfo, sortedCheckedArgTys, i, x.idRange)
CallNameResolutionSink cenv.tcSink (x.idRange,env.NameEnv,item,item,emptyTyparInst,ItemOccurence.UseInType,env.DisplayEnv,env.eAccessRights))
TType_anon(anonInfo, sortedCheckedArgTys),tpenv
Expand Down Expand Up @@ -5879,8 +5879,8 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) =
let expr = mkAnyTupled cenv.g m tupInfo args' argTys
expr, tpenv

| SynExpr.AnonRecd (isStruct, optOrigExpr, unsortedArgs, mWholeExpr) ->
TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedArgs, mWholeExpr)
| SynExpr.AnonRecd (isStruct, optOrigExpr, unsortedFieldExprs, mWholeExpr) ->
TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedFieldExprs, mWholeExpr)

| SynExpr.ArrayOrList (isArray, args, m) ->
CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.eAccessRights)
Expand Down Expand Up @@ -7036,26 +7036,39 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr


// Check '{| .... |}'
and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedArgs, mWholeExpr) =
and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigSynExpr, unsortedFieldIdsAndSynExprsGiven, mWholeExpr) =
let unsortedFieldSynExprsGiven = List.map snd unsortedFieldIdsAndSynExprsGiven

match optOrigExpr with
match optOrigSynExpr with
| None ->
let unsortedIds = unsortedArgs |> List.map fst |> List.toArray
let anonInfo, sortedArgTys = UnifyAnonRecdTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv mWholeExpr overallTy isStruct unsortedIds
let unsortedFieldIds = unsortedFieldIdsAndSynExprsGiven |> List.map fst |> List.toArray
let anonInfo, sortedFieldTys = UnifyAnonRecdTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv mWholeExpr overallTy isStruct unsortedFieldIds

// Sort into canonical order
let sortedIndexedArgs = unsortedArgs |> List.indexed |> List.sortBy (fun (i,_) -> unsortedIds.[i].idText)
let sortedIndexedArgs =
unsortedFieldIdsAndSynExprsGiven
|> List.indexed
|> List.sortBy (fun (i,_) -> unsortedFieldIds.[i].idText)

// Map from sorted indexes to unsorted indexes
let sigma = List.map fst sortedIndexedArgs |> List.toArray
let sortedArgs = List.map snd sortedIndexedArgs
sortedArgs |> List.iteri (fun j (x, _) ->
let item = Item.AnonRecdField(anonInfo, sortedArgTys, j, x.idRange)
let sortedFieldExprs = List.map snd sortedIndexedArgs

sortedFieldExprs |> List.iteri (fun j (x, _) ->
let item = Item.AnonRecdField(anonInfo, sortedFieldTys, j, x.idRange)
CallNameResolutionSink cenv.tcSink (x.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights))
let unsortedArgTys = sortedArgTys |> List.indexed |> List.sortBy (fun (j, _) -> sigma.[j]) |> List.map snd
let flexes = unsortedArgTys |> List.map (fun _ -> true)
let unsortedCheckedArgs, tpenv = TcExprs cenv env mWholeExpr tpenv flexes unsortedArgTys (List.map snd unsortedArgs)
let sortedCheckedArgs = unsortedCheckedArgs |> List.indexed |> List.sortBy (fun (i,_) -> unsortedIds.[i].idText) |> List.map snd

mkAnonRecd cenv.g mWholeExpr anonInfo sortedCheckedArgs sortedArgTys, tpenv
let unsortedFieldTys =
sortedFieldTys
|> List.indexed
|> List.sortBy (fun (sortedIdx, _) -> sigma.[sortedIdx])
|> List.map snd

let flexes = unsortedFieldTys |> List.map (fun _ -> true)

let unsortedCheckedArgs, tpenv = TcExprs cenv env mWholeExpr tpenv flexes unsortedFieldTys unsortedFieldSynExprsGiven

mkAnonRecd cenv.g mWholeExpr anonInfo unsortedFieldIds unsortedCheckedArgs unsortedFieldTys, tpenv

| Some (origExpr, _) ->
// The fairly complex case '{| origExpr with X = 1; Y = 2 |}'
Expand Down Expand Up @@ -7088,7 +7101,7 @@ and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedArgs
/// - Choice1Of2 for a new binding
/// - Choice2Of2 for a binding coming from the original expression
let unsortedIdAndExprsAll =
[| for (id, e) in unsortedArgs do
[| for (id, e) in unsortedFieldIdsAndSynExprsGiven do
yield (id, Choice1Of2 e)
match tryDestAnonRecdTy cenv.g origExprTy with
| ValueSome (anonInfo, tinst) ->
Expand All @@ -7104,32 +7117,61 @@ and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedArgs
error (Error (FSComp.SR.tcCopyAndUpdateNeedsRecordType(), mOrigExpr)) |]
|> Array.distinctBy (fst >> textOfId)

let unsortedIdsAll = Array.map fst unsortedIdAndExprsAll
let anonInfo, sortedArgTysAll = UnifyAnonRecdTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv mWholeExpr overallTy isStruct unsortedIdsAll
let sortedIndexedArgsAll = unsortedIdAndExprsAll |> Array.indexed |> Array.sortBy (snd >> fst >> textOfId)
let sigma = Array.map fst sortedIndexedArgsAll // map from sorted indexes to unsorted indexes
let sortedArgsAll = Array.map snd sortedIndexedArgsAll
sortedArgsAll |> Array.iteri (fun j (x, expr) ->
let unsortedFieldIdsAll = Array.map fst unsortedIdAndExprsAll

let anonInfo, sortedFieldTysAll = UnifyAnonRecdTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv mWholeExpr overallTy isStruct unsortedFieldIdsAll

let sortedIndexedFieldsAll = unsortedIdAndExprsAll |> Array.indexed |> Array.sortBy (snd >> fst >> textOfId)

// map from sorted indexes to unsorted indexes
let sigma = Array.map fst sortedIndexedFieldsAll

let sortedFieldsAll = Array.map snd sortedIndexedFieldsAll

// Report _all_ identifiers to name resolution. We should likely just report the ones
// that are explicit in source code.
sortedFieldsAll |> Array.iteri (fun j (x, expr) ->
match expr with
| Choice1Of2 _ ->
let item = Item.AnonRecdField(anonInfo, sortedArgTysAll, j, x.idRange)
let item = Item.AnonRecdField(anonInfo, sortedFieldTysAll, j, x.idRange)
CallNameResolutionSink cenv.tcSink (x.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights)
| Choice2Of2 _ -> ())

let unsortedArgTysNew = sortedArgTysAll |> List.indexed |> List.sortBy (fun (j, _) -> sigma.[j]) |> List.take unsortedArgs.Length |> List.map snd
let flexes = unsortedArgTysNew |> List.map (fun _ -> true)
let unsortedFieldTysAll =
sortedFieldTysAll
|> List.indexed
|> List.sortBy (fun (sortedIdx, _) -> sigma.[sortedIdx])
|> List.map snd

let unsortedFieldTysGiven =
unsortedFieldTysAll
|> List.take unsortedFieldIdsAndSynExprsGiven.Length

let flexes = unsortedFieldTysGiven |> List.map (fun _ -> true)

let unsortedCheckedArgsNew, tpenv = TcExprs cenv env mWholeExpr tpenv flexes unsortedArgTysNew (List.map snd unsortedArgs)
let sortedArgTysAllArray = Array.ofList sortedArgTysAll
let unsortedCheckedArgsNewArray = unsortedCheckedArgsNew |> List.toArray
let sortedCheckedArgsAll =
sortedArgsAll |> Array.mapi (fun j (_, expr) ->
// Check the expressions in unsorted order
let unsortedFieldExprsGiven, tpenv =
TcExprs cenv env mWholeExpr tpenv flexes unsortedFieldTysGiven unsortedFieldSynExprsGiven

let unsortedFieldExprsGiven = unsortedFieldExprsGiven |> List.toArray

let unsortedFieldIds =
unsortedIdAndExprsAll
|> Array.map fst

let unsortedFieldExprs =
unsortedIdAndExprsAll
|> Array.mapi (fun unsortedIdx (_, expr) ->
match expr with
| Choice1Of2 _ -> unsortedCheckedArgsNewArray.[sigma.[j]]
| Choice2Of2 subExpr -> UnifyTypes cenv env mOrigExpr (tyOfExpr cenv.g subExpr) sortedArgTysAllArray.[j]; subExpr)
| Choice1Of2 _ -> unsortedFieldExprsGiven.[unsortedIdx]
| Choice2Of2 subExpr -> UnifyTypes cenv env mOrigExpr (tyOfExpr cenv.g subExpr) unsortedFieldTysAll.[unsortedIdx]; subExpr)
|> List.ofArray

let expr = mkAnonRecd cenv.g mWholeExpr anonInfo (List.ofArray sortedCheckedArgsAll) sortedArgTysAll
// Permute the expressions to sorted order in the TAST
let expr = mkAnonRecd cenv.g mWholeExpr anonInfo unsortedFieldIds unsortedFieldExprs unsortedFieldTysAll
let expr = wrap expr

// Bind the original expression
let expr = mkCompGenLet mOrigExpr oldv origExprChecked expr
expr, tpenv

Expand Down
49 changes: 46 additions & 3 deletions tests/fsharp/core/anon/lib.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,7 @@ let test (s : string) b =
let check (s:string) x1 x2 =
stderr.Write(s)
if (x1 = x2) then stderr.WriteLine " OK"
else (stderr.WriteLine (sprintf "fail, expected %A, got %A" x2 x1); report_failure (s))
else (stderr.WriteLine (sprintf " failed, expected %A, got %A" x2 x1); report_failure (s))

let inline getX (x: ^TX) : ^X =
(^TX : (member get_X : unit -> ^X) (x))
Expand Down Expand Up @@ -205,13 +205,56 @@ module QuotesNewRecord2 =

open FSharp.Quotations
open FSharp.Quotations.Patterns
let ty, args = match <@ {| Y = "two"; X = 1 |} @> with NewRecord(a,b) -> a,b
let yarg,ty, args = match <@ {| Y = "two"; X = 1 |} @> with Let(_,yarg,NewRecord(a,b)) -> yarg,a,b

check "qgceoijew90ewcw1" (FSharp.Reflection.FSharpType.IsRecord(ty)) true
check "qgceoijew90ewcw2" (FSharp.Reflection.FSharpType.GetRecordFields(ty).Length) 2
// Fields are sorted
check "qgceoijew90ewcw2" ([ for p in FSharp.Reflection.FSharpType.GetRecordFields(ty) -> p.Name ]) [ "X"; "Y" ]
check "qgceoijew90ewcw3" args [ <@@ 1 @@>; <@@ "two" @@> ]
check "qgceoijew90ewcw3" args.[0] <@@ 1 @@>
check "qgceoijew90ewcw4" yarg <@@ "two" @@>

module QuotesFieldInitOrder =

let mutable x = 1
let test() =
x <- 1
{| X = (check "clwknckl1" x 1; x <- x + 1; 3)
Y = (check "cwkencelwe2" x 2; x <- x + 1; 2)
|} |> check "ceweoiwe1" {| Y=2; X=3 |}
x <- 1
{| X = (check "clwknckl3" x 1; x <- x + 1; 2)
W = (check "cwkencelwe4" x 2; x <- x + 1; 3)
|} |> check "ceweoiwe2" {| W=3; X=2 |}
x <- 1
{| X = (check "clwknckl5" x 1; x <- x + 1; 2)
Y = (check "clwknckl6" x 2; x <- x + 1; 3)
W = (check "cwkencelwe7" x 3; x <- x + 1; 4) |}
|> check "ceweoiwe" {| Y=3; X=2; W=4 |}
x <- 1
let a =
{| Y = (check "clwknckl8" x 1; x <- x + 1; 2)
X = (check "clwknckl9" x 2; x <- x + 1; 3)
W = (check "cwkencel10" x 3; x <- x + 1; 4)
|}
a |> check "ceweoiwe" {| Y=2; X=3; W=4 |}
x <- 1
let b =
{| a with
X = (check "clwknckl9" x 1; x <- x + 1; 6)
W = (check "cwkencel10" x 2; x <- x + 1; 7)
|}
b |> check "ceweoiwe87" {| Y=2; X=6; W=7 |}
x <- 1
let c =
{| a with
X = (check "clwknckl9" x 1; x <- x + 1; 6)
A = (check "cwkencel11" x 2; x <- x + 1; 8)
W = (check "cwkencel10" x 3; x <- x + 1; 7)
|}
c |> check "ceweoiwe87" {| Y=2; X=6; W=7; A=8 |}
test()


module QuotesPropertyGet =

Expand Down