From 8924a73d269935e724797a191c473005a07813c2 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sun, 11 Oct 2026 16:44:30 +0200 Subject: [PATCH 01/10] feat(quotations): add the translator project with its error type FSharp.Azure.Cosmos.Quotations is going to translate F# quotations into Azure Cosmos DB queries (ADR 0001). The translator is built stage by stage, so no package is made of the project until the stages produce a query end to end. A stage that cannot translate a quotation says why with a TranslationError: a code for the calling program, a message and hints for the person who reads it, and the offending part of the quotation as text. When the code was compiled with --quotations-debug, the error also carries the place in the source that the compiler recorded for that part; a part that a rewrite built has no place of its own, so the place of the first part inside it is taken. The error has no equality: its hints are an ImmutableArray, which equals another one only when both wrap the same array. Co-Authored-By: Claude Opus 5.5 --- .github/copilot-instructions.md | 2 + FSharp.Azure.Cosmos.slnf | 1 + FSharp.Azure.Cosmos.slnx | 1 + src/Cosmos.Quotations/AssemblyInfo.fs | 23 +++ .../FSharp.Azure.Cosmos.Quotations.fsproj | 33 ++++ src/Cosmos.Quotations/TranslationError.fs | 155 ++++++++++++++++++ 6 files changed, 215 insertions(+) create mode 100644 src/Cosmos.Quotations/AssemblyInfo.fs create mode 100644 src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj create mode 100644 src/Cosmos.Quotations/TranslationError.fs diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index 46978db5..e050e5c2 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -12,6 +12,8 @@ ```text / +├── src/Cosmos.Quotations/ – translator of F# quotations into queries (FSharp.Azure.Cosmos.Quotations), built stage by stage and not packed yet +│ └── TranslationError.fs – translation errors and the place of a quotation in the source ├── src/Cosmos/ – main library (FSharp.Azure.Cosmos) │ ├── SubStatusCodes.fs – documented Cosmos DB sub-status codes │ ├── Cosmos.fs – core types and container extensions diff --git a/FSharp.Azure.Cosmos.slnf b/FSharp.Azure.Cosmos.slnf index 1a0488cc..5f77075d 100644 --- a/FSharp.Azure.Cosmos.slnf +++ b/FSharp.Azure.Cosmos.slnf @@ -2,6 +2,7 @@ "solution": { "path": "FSharp.Azure.Cosmos.slnx", "projects": [ + "src\\Cosmos.Quotations\\FSharp.Azure.Cosmos.Quotations.fsproj", "src\\Cosmos\\FSharp.Azure.Cosmos.fsproj", "tests\\Cosmos.Tests.Infrastructure\\FSharp.Azure.Cosmos.Tests.Infrastructure.fsproj", "tests\\Cosmos.Tests\\FSharp.Azure.Cosmos.Tests.fsproj" diff --git a/FSharp.Azure.Cosmos.slnx b/FSharp.Azure.Cosmos.slnx index 4ec89bbd..19bc8997 100644 --- a/FSharp.Azure.Cosmos.slnx +++ b/FSharp.Azure.Cosmos.slnx @@ -10,6 +10,7 @@ + diff --git a/src/Cosmos.Quotations/AssemblyInfo.fs b/src/Cosmos.Quotations/AssemblyInfo.fs new file mode 100644 index 00000000..08966c65 --- /dev/null +++ b/src/Cosmos.Quotations/AssemblyInfo.fs @@ -0,0 +1,23 @@ +// Auto-Generated by FAKE; do not edit +namespace System +open System.Reflection + +[] +[] +[] +[] +[] +[] +[] +[] +do () + +module internal AssemblyVersionInformation = + let [] AssemblyTitle = "FSharp.Azure.Cosmos.Quotations" + let [] AssemblyProduct = "FSharp.Azure.Cosmos" + let [] AssemblyVersion = "1.2.0" + let [] AssemblyMetadata_ReleaseDate = "2026-10-01T00:00:00.0000000+02:00" + let [] AssemblyFileVersion = "1.2.0" + let [] AssemblyInformationalVersion = "1.2.0" + let [] AssemblyMetadata_ReleaseChannel = "release" + let [] AssemblyMetadata_GitHash = "210cf041a0ce44fcc5a5df369550a77a1f75d436" diff --git a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj new file mode 100644 index 00000000..0e4da697 --- /dev/null +++ b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj @@ -0,0 +1,33 @@ + + + + net10.0 + $(AssemblyBaseName).Quotations + true + true + + + false + + + + true + true + + + + + + + + + + all + runtime; build; native; contentfiles; analyzers; buildtransitive + + + + diff --git a/src/Cosmos.Quotations/TranslationError.fs b/src/Cosmos.Quotations/TranslationError.fs new file mode 100644 index 00000000..897746ab --- /dev/null +++ b/src/Cosmos.Quotations/TranslationError.fs @@ -0,0 +1,155 @@ +namespace FSharp.Azure.Cosmos.Quotations + +open System.Collections.Immutable +open FSharp.Quotations +open FSharp.Quotations.DerivedPatterns +open FSharp.Quotations.ExprShape +open FSharp.Quotations.Patterns + +open FSharp.Azure.Cosmos + +/// +/// The place in a source file where a part of a quotation was written. The compiler records it only when it is run with +/// --quotations-debug, so a has one only for +/// code compiled that way. +/// +[] +type SourceRange = { + /// The path of the source file, as the compiler recorded it. + File : string + /// The line the part starts at; the first line of a file is 1. + StartLine : int + /// The column the part starts at; the first column of a line is 0. + StartColumn : int + /// The line the part ends at. + EndLine : int + /// The column the part ends at. + EndColumn : int +} + +/// +/// The reason a reports. +/// +[] +type TranslationErrorCode = + /// A construct of F# that a query has no counterpart for, such as a loop, an assignment or a recursive function. + | Unsupported + /// + /// A function that exists only as a compiled value is applied to a value of the document. A compiled function + /// cannot be read, so it cannot become a part of the query; a quotation or a function marked with + /// can. + /// + | CapturedFunctionValue + /// + /// The quotation cannot be brought into its simplest form: a function marked with + /// calls itself, or the simplification did not + /// finish within its limit of steps. + /// + | NormalizationDiverged + +/// +/// Why a quotation cannot be translated into a query, with the part of the quotation that is the reason. +/// +/// +/// The type has no equality, because is an +/// , which is equal to another one only when both wrap +/// the same array. Compare the . +/// +[] +type TranslationError = { + /// The reason, for code that handles the error. + Code : TranslationErrorCode + /// What is wrong, in English. + Message : string + /// The part of the quotation that is the reason, as text; empty when the error is about the quotation as a whole. + Fragment : string + /// + /// Where the part was written, when the compiler recorded it: see + /// . + /// + Location : SourceRange voption + /// What to write instead, in English; empty when there is no general advice. + Hints : ImmutableArray +} + +/// +/// Reads the that the compiler attached to a part of a +/// quotation. +/// +[] +module internal SourceRange = + + /// + /// The range in one custom attribute of a quotation node. The compiler writes it as the pair of the name + /// DebugRange and the tuple of the file, the start line and column and the end line and column. + /// + [] + let private (|DebugRange|_|) (attribute : Expr) : SourceRange voption = + match attribute with + | NewTuple [ String "DebugRange" + NewTuple [ String file; Int32 startLine; Int32 startColumn; Int32 endLine; Int32 endColumn ] ] -> + ValueSome { + File = file + StartLine = startLine + StartColumn = startColumn + EndLine = endLine + EndColumn = endColumn + } + | _ -> ValueNone + + /// + /// The range of , or of the first part inside it that has one: a node that a rewrite built + /// has none of its own, but the parts it was built from keep theirs. + /// + let rec tryOfQuotation (expr : Expr) : SourceRange voption = + let own = + expr.CustomAttributes + |> List.tryPick (fun attribute -> + match attribute with + | DebugRange range -> ValueSome range + | _ -> ValueNone + ) + + match own with + | ValueSome _ -> own + | ValueNone -> + match expr with + | ShapeVar _ -> ValueNone + | ShapeLambda (_, body) -> tryOfQuotation body + | ShapeCombination (_, parts) -> parts |> List.tryPick tryOfQuotation + +/// +/// Builds a about a part of a quotation. +/// +[] +module internal TranslationError = + + /// + /// The error with , and about + /// , which gives the error its text and, when the compiler recorded one, its place in + /// the source. + /// + let ofQuotation + (code : TranslationErrorCode) + (message : string) + (hints : ImmutableArray) + (fragment : Expr) + : TranslationError = { + Code = code + Message = message + Fragment = string fragment + Location = SourceRange.tryOfQuotation fragment + Hints = hints + } + + /// + /// The error with and about a quotation as a whole: it names no + /// part of it. + /// + let ofWhole (code : TranslationErrorCode) (message : string) : TranslationError = { + Code = code + Message = message + Fragment = "" + Location = ValueNone + Hints = ImmutableArray.Empty + } From 8ebb032f8fae124aff343d75a2baa5c9157a124a Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Mon, 12 Oct 2026 10:22:33 +0200 Subject: [PATCH 02/10] feat(quotations): bring a quotation into its normal form One condition can be written in many ways: with pipes, composition, let bindings, functions marked with ReflectedDefinition and spliced quotations. The stages after this one should not have to know every spelling, so the normalizer rewrites them away. What is left holds operators, members of the document and calls whose code cannot be read. Rewritten away: - |>, <|, ||>, |||>, <||, <|||, >> and <<, recognised by the methods of FSharp.Core and never by name; - a function that is written and applied in place, and a let whose variable is never assigned to. That includes what the compiler binds itself: the value a match looks at, the parts of a tuple pattern and the copy of a struct, which is a mutable variable when the compiler cannot tell that the called member leaves the struct alone; - a call of a function, method, property getter or extension member with a reflected definition, also an inline one that takes its operators as witnesses, a generic one and a member of a base class. A member that a derived class can override stays a call, and so does a module-level value, which is computed once; - the reading of an item, field or case of a tuple, record, anonymous record or union that is built in the same place, and fst, snd and Item1..Item7, which become the reading of an item; - a comparison of a boolean with true or false, a choice between true and false, a condition that is a constant and a double negation. The branch that a constant condition does not choose is not read at all: code that never runs needs no normal form. A captured boolean is not a constant: it is a parameter of the query. The default value of a boolean, which the compiler writes for bool (), is false; - the witnesses of a call, the address of a struct anonymous record and the compiled value that an auto-quoted argument carries. Reported as a TranslationError instead: - a call of a function with a reflected definition that calls itself, directly or through others, when the call reads a value of the document; - a quotation whose rewriting does not end, after 10 000 steps or when the stack of the thread runs low, whichever comes first; - a compiled function that is applied to a value of the document, however the quotation gets to it: by its name, from a property or a field of a captured value, or as what a call returns. A function that the document chooses, as the result of a choice does, is reported as one that is chosen when the query runs. An application to captured values only is left for the stage that computes values outside the query; - a mutable variable that is assigned to, an assignment, the address of a value, a sequence of statements, a loop, exception handling and a recursive function. Of the constructs that stay in the normal form, the outermost one is reported. An assignment, a sequence of statements, a loop, exception handling and a recursive function are errors whatever is inside them, so the outermost of these is reported also when the quotation inside it has no normal form at all. A quotation that is nested too deeply stays the error whatever stands around it: the error of a construct shows the construct, and printing something that deep needs the stack that has run out. Only what stays is an error. A call of a function that calls itself is not replaced by its definition, which would never end: it stays a call, and so does the call that led to it. What becomes of such a call is decided when the whole quotation is normalized. One that reads a value of the document is the error. One that reads none is a value to compute outside the query, as a call of any compiled function is. And one in code that never runs is gone by then, so the branch that a constant does not choose may hold one however the constant gets to the condition: bound by a let, passed to a function written in place or to a function with a definition. The compiler keeps the definition of an inline function of a module for the form of the function that takes the witnesses, and the definition of an inline member of a type for the member itself; both take the witnesses first, then the receiver, then the arguments. A definition is applied only to arguments of the types it takes: a call that is built through the API can pass an inline member no witnesses, and such a call stays a call. Reflected definitions and the argument groups of their methods are kept for the process: FSharp.Core unpickles a definition on every lookup, which took 16 microseconds here, and searches the resources of the assembly for a method that has none, which took one. Substitution is left to FSharp.Core where nothing inside the body needs care, because it builds nodes without validating them, while rebuilding one member access through the public API cost 4 microseconds of reflection. Two things need care. One variable can be bound at several places, since a quotation that is spliced twice arrives as the same nodes, so a binding that hides the variable or would capture a variable of the value is respected, also when the question is whether a mutable variable is assigned to. And a value that is bound once and used at several places has to be one node at all of them: the code computes it once, and the stage that computes values outside the query tells by the node that the places are one value. FSharp.Core builds every node of a body anew, which makes two nodes of such a value as soon as something else is written into the body that holds it. So a body with such a node is substituted node by node, and the node is rewritten and normalized once for all its places. The places are those of one call: the definition of a function is one tree for the process, so every call after the first normalizes a copy of it, and a value that the function binds is not one node across calls, which each compute it for themselves. A node that the quotation comes with at several places is kept one node in the same way: a quotation that is spliced into two places is the same nodes at both, and code can build a tree with one node twice. The quotation is walked once for such nodes before it is normalized, and not to its end when it is nested too deeply, which the normalization then reports. Co-Authored-By: Claude Opus 5.5 --- .github/copilot-instructions.md | 3 +- .../FSharp.Azure.Cosmos.Quotations.fsproj | 1 + src/Cosmos.Quotations/Normalizer.fs | 1277 +++++++++++++++++ 3 files changed, 1280 insertions(+), 1 deletion(-) create mode 100644 src/Cosmos.Quotations/Normalizer.fs diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index e050e5c2..6e8dbb54 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -13,7 +13,8 @@ ```text / ├── src/Cosmos.Quotations/ – translator of F# quotations into queries (FSharp.Azure.Cosmos.Quotations), built stage by stage and not packed yet -│ └── TranslationError.fs – translation errors and the place of a quotation in the source +│ ├── TranslationError.fs – translation errors and the place of a quotation in the source +│ └── Normalizer.fs – normal form of a quotation ├── src/Cosmos/ – main library (FSharp.Azure.Cosmos) │ ├── SubStatusCodes.fs – documented Cosmos DB sub-status codes │ ├── Cosmos.fs – core types and container extensions diff --git a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj index 0e4da697..839b1b02 100644 --- a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj +++ b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj @@ -21,6 +21,7 @@ + diff --git a/src/Cosmos.Quotations/Normalizer.fs b/src/Cosmos.Quotations/Normalizer.fs new file mode 100644 index 00000000..81dcc39d --- /dev/null +++ b/src/Cosmos.Quotations/Normalizer.fs @@ -0,0 +1,1277 @@ +/// +/// Brings a quotation into its normal form, the one form that every spelling of the same condition has. Pipes, +/// composition, bindings, calls of functions marked with +/// and splices of other quotations are only ways of +/// writing; after normalization they are gone, and what is left says what is computed from the document. +/// +/// +/// +/// A quotation is in normal form when none of these is left in it: +/// +/// +/// a call of a pipe or composition operator of FSharp.Core; +/// a function written in place and applied in place, or a whose variable +/// is never assigned to; +/// a call of a function, method or property getter that has a reflected definition and can be +/// replaced by it. Four kinds of them stay: a call of a member that a derived class can override, the reading of a +/// module-level value, a call that does not pass the arguments its definition takes, which only a quotation built +/// through the API can hold, and a call of a function that calls itself, directly or through the functions it calls, +/// because writing its definition in its place would never end; +/// a call that passes witnesses, which the compiler writes for an operator with a member +/// constraint such as +; +/// the address of a value as the receiver of a property, which the compiler writes for a struct +/// anonymous record; +/// the reading of a part of a tuple, record or union case that is built in the same +/// place; +/// a condition that is a constant, a comparison of a boolean with a constant, or a double +/// negation. +/// +/// +/// What a query cannot express even then is an error: see +/// . +/// +/// +/// A value bound by is written at every place it is used, and so is the argument of a function +/// that is written and applied in place. Every such place holds the very same node, also after what is rewritten +/// around the node and inside it later, so a stage that computes a value outside the query can tell that the places +/// are one value and computes it once, as the code does. +/// +/// +/// A node that stands at several places of the quotation as it comes stays one node in the same way: a quotation that +/// is spliced into two places is the same nodes at both, and code can build a tree with one node twice. +/// +/// +module internal FSharp.Azure.Cosmos.Quotations.Normalizer + +open System +open System.Collections.Concurrent +open System.Collections.Frozen +open System.Collections.Generic +open System.Collections.Immutable +open System.Reflection +open System.Runtime.CompilerServices +open FSharp.Quotations +open FSharp.Quotations.ExprShape +open FSharp.Quotations.Patterns +open FSharp.Reflection + +open FSharp.Azure.Cosmos + +/// The functions of FSharp.Core that normalization rewrites. +[] +type private KnownFunction = + /// The forward pipe of one value. + | PipeRight + /// The forward pipe of two values. + | PipeRight2 + /// The forward pipe of three values. + | PipeRight3 + /// The backward pipe of one value. + | PipeLeft + /// The backward pipe of two values. + | PipeLeft2 + /// The backward pipe of three values. + | PipeLeft3 + /// The forward composition of two functions. + | ComposeRight + /// The backward composition of two functions. + | ComposeLeft + /// The negation of a boolean. + | Not + /// The equality operator. + | Equality + /// The inequality operator. + | Inequality + /// The first item of a pair. + | Fst + /// The second item of a pair. + | Snd + +/// +/// The largest number of rewriting steps one normalization takes before it gives up with +/// . A step removes one pipe, +/// binding, call or projection, so a quotation written by hand needs a few dozen. +/// +[] +let private MaxRewrites = 10_000 + +/// The name of a variable that normalization introduces; the compiler names its own generated variables this way. +[] +let private GeneratedVariableName = "_arg1" + +/// +/// The method that calls. +/// +let private calledMethod (call : Expr) : MethodInfo = + match call with + | Call (_, method, _) -> method + | _ -> invalidArg (nameof call) $"The quotation is not a call: %A{call}" + +/// +/// The negation of FSharp.Core, . +/// +let private notMethod = calledMethod <@ not true @> + +/// +/// The module of FSharp.Core that declares every +/// : +/// . +/// +let private operatorsModule = notMethod.DeclaringType + +/// +/// The functions of FSharp.Core that normalization rewrites, by the metadata token of the method, which every +/// instantiation of a generic function shares. The methods are taken from quotations that call them, never from names, +/// so another function with the name of an operator is not mistaken for it. +/// +let private knownFunctions : FrozenDictionary = + seq { + struct (calledMethod <@ true |> not @>, KnownFunction.PipeRight) + struct (calledMethod <@ (true, true) ||> (&&) @>, KnownFunction.PipeRight2) + struct (calledMethod + <@ + (true, true, true) + |||> (fun first second third -> first && second && third) + @>, + KnownFunction.PipeRight3) + struct (calledMethod <@ not <| true @>, KnownFunction.PipeLeft) + struct (calledMethod <@ (&&) <|| (true, true) @>, KnownFunction.PipeLeft2) + struct (calledMethod + <@ + (fun first second third -> first && second && third) + <||| (true, true, true) + @>, + KnownFunction.PipeLeft3) + struct (calledMethod <@ not >> not @>, KnownFunction.ComposeRight) + struct (calledMethod <@ not << not @>, KnownFunction.ComposeLeft) + struct (notMethod, KnownFunction.Not) + struct (calledMethod <@ true = true @>, KnownFunction.Equality) + struct (calledMethod <@ true <> true @>, KnownFunction.Inequality) + struct (calledMethod <@ fst (true, true) @>, KnownFunction.Fst) + struct (calledMethod <@ snd (true, true) @>, KnownFunction.Snd) + } + |> _.ToFrozenDictionary((fun (struct (method, _)) -> method.MetadataToken), (fun (struct (_, known)) -> known)) + +/// +/// Which is, when it +/// is one. +/// +let private knownFunctionOf (method : MethodInfo) : KnownFunction voption = + if Type.(=) (method.DeclaringType, operatorsModule) then + match knownFunctions.TryGetValue method.MetadataToken with + | true, known -> ValueSome known + | _ -> ValueNone + else + ValueNone + +/// +/// A call of one of the s, with its arguments. +/// +[] +let private (|KnownCall|_|) (expr : Expr) : struct (KnownFunction * Expr list) voption = + match expr with + | Call (None, method, arguments) -> + match knownFunctionOf method with + | ValueSome known -> ValueSome struct (known, arguments) + | ValueNone -> ValueNone + | _ -> ValueNone + +/// +/// A boolean that is written in the quotation or left there by a rewrite. A captured boolean is not one: it is a +/// parameter of the query, and the text of a query never depends on the value of a parameter. +/// +/// +/// The default value of the type is written another way: the compiler writes it for a +/// boolean that is made with its constructor, bool (), and a quotation that is built by hand may hold it. Left +/// as a condition, it would keep both branches in the quotation as code that runs. +/// +[] +let private (|Constant|_|) (expr : Expr) : bool voption = + match expr with + | ValueWithName _ -> ValueNone + | Value (:? bool as value, _) -> ValueSome value + | DefaultValue valueType when Type.(=) (valueType, typeof) -> ValueSome false + | _ -> ValueNone + +/// +/// The reflected definitions that were looked up, by method; no value for a method that has none. FSharp.Core searches +/// the resources of the declaring assembly on every lookup of a method without a definition, which takes microseconds, +/// and a predicate asks for every call in it, operators included. A reflected definition is a fact of the assembly, +/// so the answers are kept for the process. +/// +let private reflectedDefinitions = ConcurrentDictionary() + +/// +/// Looks the reflected definition of a method up in FSharp.Core; a delegate that is created once, for +/// . +/// +let private lookUpReflectedDefinition = + Func(fun method -> + Expr.TryGetReflectedDefinition method + |> ValueOption.ofOption + ) + +/// +/// The reflected definition of , when it has one. +/// +let private reflectedDefinitionOf (method : MethodBase) : Expr voption = + reflectedDefinitions.GetOrAdd (method, lookUpReflectedDefinition) + +/// Whether two methods are one method of one type, whatever types its generic parameters stand for. +let private isSameDefinition (first : MethodBase) (second : MethodBase) : bool = + first.MetadataToken = second.MetadataToken + && first.Module.Equals second.Module + +/// +/// Whether is one of , whatever types its generic parameters +/// stand for. A loop over the indexes, because the check of what is left asks for every call of a quotation, and the +/// list is empty nearly always. +/// +let private isAmong (methods : IReadOnlyList) (method : MethodBase) : bool = + let mutable found = false + + for index in 0 .. methods.Count - 1 do + found <- found || isSameDefinition methods[index] method + + found + +/// Whether two lists hold the very same nodes, which means that a rewrite of the first changed nothing. +let rec private areSame (first : Expr list) (second : Expr list) : bool = + match first, second with + | [], [] -> true + | firstHead :: firstTail, secondHead :: secondTail -> + obj.ReferenceEquals (firstHead, secondHead) + && areSame firstTail secondTail + | _ -> false + +/// +/// What is known about the body of a binding before the bound value is written into it. +/// +[] +type private Survey = { + /// How many places read the variable. + Uses : int + /// + /// Whether the value cannot simply be written at those places: the body binds the variable again, it binds a free + /// variable of the value, or it holds a node that stands at several places and has to stay one node. + /// + NeedsCare : bool +} + +/// +/// Looks at , the body of a binding of , before a value with the +/// free variables is written into it. +/// +/// +/// The case of a function sees every binding, whatever construct makes it. A quotation keeps the variable of a +/// , of a recursive function, of a loop, of an exception handler and of a delegate in a function +/// among the parts of that node, and those parts are what the shape of the node gives. +/// +/// The variable that the value is bound to. +/// The free variables of the value. +/// The nodes that stand at several places, by their identity. +/// The body of the binding, or a part of it. +let rec private survey (variable : Var) (freeInValue : HashSet) (shared : HashSet) (expr : Expr) : Survey = + match expr with + | ShapeVar candidate -> { + Uses = (if obj.ReferenceEquals (candidate, variable) then 1 else 0) + NeedsCare = false + } + | ShapeLambda (bound, body) -> + let inside = survey variable freeInValue shared body + + { + inside with + NeedsCare = + inside.NeedsCare + || obj.ReferenceEquals (bound, variable) + || freeInValue.Contains bound + || (shared.Count > 0 && shared.Contains expr) + } + | ShapeCombination (_, parts) -> + let mutable uses = 0 + let mutable needsCare = shared.Count > 0 && shared.Contains expr + + for part in parts do + let inside = survey variable freeInValue shared part + uses <- uses + inside.Uses + needsCare <- needsCare || inside.NeedsCare + + { Uses = uses; NeedsCare = needsCare } + +/// +/// Replaces the free occurrences of in with +/// , with care for the bindings inside and for the nodes in it that +/// stand at several places. +/// +/// +/// +/// One variable can be bound at several places of a quotation: a quotation that is spliced twice arrives as the same +/// nodes each time, and every call of a function with a reflected definition gets nodes of its own that bind the +/// variables of the one definition. So an inner binding of +/// hides it and is left alone, and a binding that would capture a free variable of +/// is renamed first. +/// +/// +/// A node without the variable is returned as it is, so a node that stands at several places stays one node. When such +/// a node holds the variable, it is built anew at the first of its places, and gives the +/// other places the same new node. +/// +/// +/// The variable to replace. +/// What takes its place. +/// The free variables of . +/// +/// The nodes that stand at several places, by their identity. A node that takes the place of one of them is added. +/// +/// +/// What this replacing has made of the nodes that stand at several places so far, by their identity. +/// +/// The quotation to replace it in. +let rec private substituteWithCare + (variable : Var) + (value : Expr) + (freeInValue : HashSet) + (shared : HashSet) + (replaced : Dictionary) + (expr : Expr) + : Expr = + if shared.Count > 0 && shared.Contains expr then + match replaced.TryGetValue expr with + | true, known -> known + | _ -> + let replacement = substituteInParts variable value freeInValue shared replaced expr + replaced.Add (expr, replacement) + shared.Add replacement |> ignore + replacement + else + substituteInParts variable value freeInValue shared replaced expr + +/// +/// What +/// +/// makes of a node that it has not replaced before. +/// +and private substituteInParts + (variable : Var) + (value : Expr) + (freeInValue : HashSet) + (shared : HashSet) + (replaced : Dictionary) + (expr : Expr) + : Expr = + match expr with + | ShapeVar candidate -> + if obj.ReferenceEquals (candidate, variable) then + value + else + expr + | ShapeLambda (bound, _) when obj.ReferenceEquals (bound, variable) -> expr + | ShapeLambda (bound, body) when freeInValue.Contains bound -> + let renamed = Var (bound.Name, bound.Type, bound.IsMutable) + + // The renaming is a replacing of its own, with its own account of what it made of which node. + let renamedBody = + substituteWithCare + bound + (Expr.Var renamed) + (HashSet [ renamed ]) + shared + (Dictionary ReferenceEqualityComparer.Instance) + body + + Expr.Lambda (renamed, substituteWithCare variable value freeInValue shared replaced renamedBody) + | ShapeLambda (bound, body) -> + let newBody = substituteWithCare variable value freeInValue shared replaced body + if obj.ReferenceEquals (newBody, body) then + expr + else + Expr.Lambda (bound, newBody) + | ShapeCombination (shape, parts) -> + let newParts = + parts + |> List.map (substituteWithCare variable value freeInValue shared replaced) + if areSame parts newParts then + expr + else + RebuildShapeCombination (shape, newParts) + +/// +/// with at every place where is used. +/// +/// +/// +/// A value that is written at more than one place is the same node at all of them, and it is added to +/// , the nodes that have to stay one node from then on. The code computes such a value once, +/// and a later stage tells by the node that the places are one value. +/// +/// +/// When nothing inside needs care, which is nearly always, the replacing is left to +/// . +/// It builds its nodes without validating them, while +/// +/// asks reflection whether the declaring type of every member it rebuilds an access to is a union, which takes +/// microseconds for each access. +/// +/// +/// Otherwise +/// +/// does it. The function of FSharp.Core replaces a variable inside an inner binding of the same variable too, and it +/// builds every node of the body anew, so a node that stands at two places would come out as two nodes. +/// +/// +let private bind (shared : HashSet) (variable : Var) (value : Expr) (body : Expr) : Expr = + let freeInValue = HashSet(value.GetFreeVars ()) + let found = survey variable freeInValue shared body + + if found.Uses = 0 then + body + else + // A variable is no node to keep: every place that reads it is a node of its own already. + match value with + | Var _ -> () + | _ when found.Uses > 1 -> shared.Add value |> ignore + | _ -> () + + if found.NeedsCare then + substituteWithCare variable value freeInValue shared (Dictionary ReferenceEqualityComparer.Instance) body + else + body.Substitute (fun candidate -> + if obj.ReferenceEquals (candidate, variable) then + Some value + else + None + ) + +/// +/// Whether assigns to or takes its address, through which it can +/// be assigned to. +/// +/// +/// A binding of the same variable inside hides it: what is assigned to under that binding is +/// the variable of that binding. One variable is bound at two nested places in a quotation that is built through the +/// API or spliced into itself. +/// +let rec private isChanged (variable : Var) (expr : Expr) : bool = + match expr with + | VarSet (target, _) when obj.ReferenceEquals (target, variable) -> true + | AddressOf (Var target) when obj.ReferenceEquals (target, variable) -> true + | ShapeVar _ -> false + | ShapeLambda (bound, _) when obj.ReferenceEquals (bound, variable) -> false + | ShapeLambda (_, body) -> isChanged variable body + | ShapeCombination (_, parts) -> parts |> List.exists (isChanged variable) + +/// +/// The function that applies and then , written as a function of +/// one parameter. The parameter takes the name of the parameter of when that is written as a +/// function, so that a name the user chose survives. +/// +let private compose (first : Expr) (second : Expr) : Expr = + let name = + match first with + | Lambda (parameter, _) -> parameter.Name + | _ -> GeneratedVariableName + + let parameter = Var (name, FSharpType.GetFunctionElements first.Type |> fst) + Expr.Lambda (parameter, Expr.Application (second, Expr.Application (first, Expr.Var parameter))) + +/// +/// Pipes and composition: x |> f and f <| x are f x, the pipes of two and three values +/// apply the function to the values in turn, and f >> g and g << f are +/// fun x -> g (f x). +/// +let private eliminatePipeOrComposition (known : KnownFunction) (arguments : Expr list) : Expr voption = + match known, arguments with + | KnownFunction.PipeRight, [ argument; func ] + | KnownFunction.PipeLeft, [ func; argument ] -> ValueSome (Expr.Application (func, argument)) + | KnownFunction.PipeRight2, [ first; second; func ] + | KnownFunction.PipeLeft2, [ func; first; second ] -> ValueSome (Expr.Applications (func, [ [ first ]; [ second ] ])) + | KnownFunction.PipeRight3, [ first; second; third; func ] + | KnownFunction.PipeLeft3, [ func; first; second; third ] -> + ValueSome (Expr.Applications (func, [ [ first ]; [ second ]; [ third ] ])) + | KnownFunction.ComposeRight, [ first; second ] + | KnownFunction.ComposeLeft, [ second; first ] -> ValueSome (compose first second) + | _ -> ValueNone + +/// +/// and +/// are the reading of an item of a +/// tuple, the one form the other rules and the later stages know. +/// +let private eliminatePairFunction (known : KnownFunction) (arguments : Expr list) : Expr voption = + match known, arguments with + | KnownFunction.Fst, [ pair ] -> ValueSome (Expr.TupleGet (pair, 0)) + | KnownFunction.Snd, [ pair ] -> ValueSome (Expr.TupleGet (pair, 1)) + | _ -> ValueNone + +/// +/// The negation of . +/// +let private negate (condition : Expr) : Expr = Expr.Call (notMethod, [ condition ]) + +/// +/// Booleans in one form, the calls: a boolean compared with a constant is itself or its negation, the negation of a +/// constant is a constant, and a double negation is gone. +/// +let private canonicalBooleanCall (known : KnownFunction) (arguments : Expr list) : Expr voption = + match known, arguments with + | KnownFunction.Not, [ Constant value ] -> ValueSome (Expr.Value (not value)) + | KnownFunction.Not, [ KnownCall (KnownFunction.Not, [ condition ]) ] -> ValueSome condition + | KnownFunction.Equality, [ condition; Constant true ] + | KnownFunction.Equality, [ Constant true; condition ] + | KnownFunction.Inequality, [ condition; Constant false ] + | KnownFunction.Inequality, [ Constant false; condition ] -> ValueSome condition + | KnownFunction.Equality, [ condition; Constant false ] + | KnownFunction.Equality, [ Constant false; condition ] + | KnownFunction.Inequality, [ condition; Constant true ] + | KnownFunction.Inequality, [ Constant true; condition ] -> ValueSome (negate condition) + | _ -> ValueNone + +/// +/// Booleans in one form, the choices: a condition that is a constant is the branch it chooses, and a choice between +/// and is its condition or the negation of it. && and +/// || need no rule of their own: the compiler writes them as a choice already. +/// +let private canonicalChoice (condition : Expr) (whenTrue : Expr) (whenFalse : Expr) : Expr voption = + match condition, whenTrue, whenFalse with + | Constant chosen, _, _ -> ValueSome (if chosen then whenTrue else whenFalse) + | _, Constant true, Constant false -> ValueSome condition + | _, Constant false, Constant true -> ValueSome (negate condition) + | _ -> ValueNone + +/// +/// The index of the item that the property of a reference tuple with reads: +/// Item1 to Item7. +/// +let private tupleItemIndex (name : string) : int voption = + if + name.Length = 5 + && name.StartsWith ("Item", StringComparison.Ordinal) + && name[4] >= '1' + && name[4] <= '7' + then + ValueSome (int name[4] - int '1') + else + ValueNone + +/// +/// The value among that reads, when it is one of +/// , which are in the order of the values. +/// +let private valueOfField (fields : PropertyInfo array) (values : Expr list) (property : PropertyInfo) : Expr voption = + fields + |> Array.tryFindIndex (fun field -> String.Equals (field.Name, property.Name, StringComparison.Ordinal)) + |> ValueOption.map (fun index -> values[index]) + +/// +/// The reading of a field of a record, an anonymous record or a union case that is built in the same place is the value +/// the field was given. The properties Item1 to Item7 of a reference tuple become the reading of an item +/// of the tuple. +/// +let private eliminatePropertyOfBuiltValue (receiver : Expr) (property : PropertyInfo) : Expr voption = + match receiver with + | NewRecord (recordType, values) -> + property + |> valueOfField (FSharpType.GetRecordFields (recordType, BindingFlags.Public ||| BindingFlags.NonPublic)) values + | NewUnionCase (case, values) -> property |> valueOfField (case.GetFields ()) values + | _ -> + match tupleItemIndex property.Name with + | ValueSome index when + FSharpType.IsTuple receiver.Type + && not receiver.Type.IsValueType + -> + ValueSome (Expr.TupleGet (receiver, index)) + | _ -> ValueNone + +/// +/// Whether a call of always runs the code of . A member that a +/// derived class can override does not: its definition says nothing about what the override does, so such a call is +/// left a call. +/// +let private isStaticallyBound (method : MethodBase) : bool = + not method.IsVirtual + || method.IsFinal + || ( + match method.DeclaringType with + | null -> false + | declaringType -> declaringType.IsSealed + ) + +/// +/// The sizes of the groups that the definitions of methods take their arguments in, by method; empty for a method that +/// takes them as one group. They are kept for the process like the definitions, because reading an attribute takes +/// microseconds too. +/// +let private argumentGroupSizes = ConcurrentDictionary>() + +/// +/// Reads the sizes of the argument groups of a method from its +/// ; a delegate that is created once, for +/// . +/// +let private readArgumentGroupSizes = + Func>(fun method -> + match method.GetCustomAttribute() with + | null -> ImmutableArray.Empty + | counts -> ImmutableArray.CreateRange counts.Counts + ) + +/// +/// Splits the arguments of a call into the groups that the definition of the called function takes one after another. +/// The compiler passes the arguments of a curried function as one flat list and records the sizes of the groups in +/// ; without it there is one group. An empty +/// group stands for the unit argument. +/// +let private argumentGroups (method : MethodBase) (arguments : Expr list) : Expr list list = + let sizes = argumentGroupSizes.GetOrAdd (method, readArgumentGroupSizes) + + if sizes.IsEmpty then + [ arguments ] + else + sizes + |> Seq.mapFold (fun rest size -> rest |> List.splitAt size) arguments + |> fst + |> Seq.toList + +/// +/// as takes it after its first +/// parameters, which take the witnesses: a member of a base class is defined for the base class, so a receiver of a +/// derived class is passed as the base class. +/// +let rec private receiverFor (skipped : int) (definition : Expr) (receiver : Expr) : Expr = + match definition with + | Lambda (_, body) when skipped > 0 -> receiverFor (skipped - 1) body receiver + | Lambda (parameter, _) when not (Type.(=) (parameter.Type, receiver.Type)) -> Expr.Coerce (receiver, parameter.Type) + | _ -> receiver + +/// +/// The reflected definition of an inline function or member that is called with witnesses, with the method that the +/// definition is kept for. The compiler keeps the definition of a function of a module for the form of the function +/// that takes the witnesses, and the definition of a member of a type for the member itself. Either definition takes +/// the witnesses first, then the receiver, then the arguments. +/// +let private definitionWithWitnesses (method : MethodInfo) (witnessMethod : MethodInfo) : struct (MethodBase * Expr) voption = + match reflectedDefinitionOf witnessMethod with + | ValueSome definition -> ValueSome struct (witnessMethod :> MethodBase, definition) + | ValueNone -> + reflectedDefinitionOf method + |> ValueOption.map (fun definition -> struct (method :> MethodBase, definition)) + +/// +/// Whether a function of takes one after another, every +/// group as one argument: a tuple when the group has several values, the unit value when it has none. +/// +/// +/// A definition is applied only to arguments it takes. The compiler calls a method with the arguments of its +/// definition, but a quotation that is built through the API can call an inline member without the witnesses that the +/// definition of the member takes first, and +/// +/// raises an exception for an argument of another type. +/// +let rec private takes (functionType : Type) (groups : Expr list list) : bool = + match groups with + | [] -> true + | group :: rest -> + functionType.IsGenericType + && Type.(=) (functionType.GetGenericTypeDefinition (), typedefof<_ -> _>) + && (let types = functionType.GetGenericArguments () + + let argumentType = + match group with + | [] -> typeof + | [ argument ] -> argument.Type + | arguments -> FSharpType.MakeTupleType (arguments |> Seq.map _.Type |> Seq.toArray) + + Type.(=) (types[0], argumentType) && takes types[1] rest) + +/// +/// The error for a call of a function with a reflected definition that calls itself, when the call reads a value of +/// the document. +/// +/// What calls itself, as the message names it. +/// The call. +let private recursiveDefinition (subject : string) (call : Expr) : TranslationError = + call + |> TranslationError.ofQuotation + TranslationErrorCode.NormalizationDiverged + $"%s{subject} calls itself, directly or through the functions it calls, so its definition cannot be written into a query." + (ImmutableArray.Create + "Call the function outside the quotation and use its result, or write the condition without recursion.") + +/// +/// The error for a quotation whose simplification does not end. It names no part of the quotation: what is at hand +/// when the limit is reached is a product of the rewriting, not something the user wrote. +/// +let private tooManyRewrites : TranslationError = + TranslationError.ofWhole + TranslationErrorCode.NormalizationDiverged + $"The quotation was not brought into its simplest form within %d{MaxRewrites} rewriting steps: its simplification does not end." + +/// +/// The error for a quotation that is nested more deeply than the stack of the thread can follow. It names no part of +/// the quotation, because printing that part would need the stack that has run out. +/// +let private nestedTooDeeply : TranslationError = + TranslationError.ofWhole + TranslationErrorCode.NormalizationDiverged + "The quotation is nested too deeply to be brought into its simplest form." + +/// +/// The error for a construct of F# that a query has no counterpart for. +/// +let private unsupported (construct : string) (hint : string) (expr : Expr) : TranslationError = + expr + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + $"A query cannot express %s{construct}." + (ImmutableArray.Create hint) + +/// +/// The error for when it is a construct that a query cannot express whatever stands inside it: +/// a recursive function, an assignment, a sequence of statements, a loop or exception handling. +/// +let private neverExpressed (expr : Expr) : TranslationError voption = + match expr with + | LetRecursive _ -> + expr + |> unsupported "a recursive function" "Write the condition without recursion." + |> ValueSome + | VarSet _ + | PropertySet _ + | FieldSet _ + | AddressSet _ -> + expr + |> unsupported "an assignment" "A query only reads the document." + |> ValueSome + | Sequential _ -> + expr + |> unsupported "a sequence of statements" "Write one expression." + |> ValueSome + | ForIntegerRangeLoop _ + | WhileLoop _ -> + expr + |> unsupported "a loop" "Use the functions of the List, Array and Seq modules on the collections of the document." + |> ValueSome + | TryWith _ + | TryFinally _ -> + expr + |> unsupported "exception handling" "A query does not raise exceptions." + |> ValueSome + | _ -> ValueNone + +/// +/// The nodes of that stand at more than one place of it, by their identity. +/// +/// +/// +/// The compiler makes a node of its own for every place of a quotation, so a node stands at two places only when +/// something put it there: a quotation that is spliced into two places is the same nodes at both, and code can build +/// a tree with one node twice. A later stage takes one node for one value, so such a node has to stay one node +/// through every rewrite, as a value that a binds does. +/// +/// +/// A variable is no such node: every place that reads it reads the one variable anyway. A quotation that is nested +/// too deeply is not walked to its end; the normalization that follows reports it. +/// +/// +let private nodesAtSeveralPlacesOf (expr : Expr) : HashSet = + let seen = HashSet ReferenceEqualityComparer.Instance + let several = HashSet ReferenceEqualityComparer.Instance + + let rec visit (expr : Expr) : unit = + match expr with + | Var _ -> () + | _ -> + if not (seen.Add expr) then + // Its parts were walked at the first place. + several.Add expr |> ignore + elif RuntimeHelpers.TryEnsureSufficientExecutionStack () then + match expr with + | ShapeLambda (_, body) -> visit body + | ShapeCombination (_, parts) -> List.iter visit parts + | ShapeVar _ -> () + + visit expr + several + +/// +/// One normalization: it holds what the rewriting of one quotation has to remember. +/// +/// The quotation that is normalized. +type private Normalization (quotation : Expr) = + + /// + /// The functions whose reflected definitions are being normalized right now, the innermost on top. A call of one + /// of them inside such a definition is a recursion. + /// + let inlining = Stack() + + /// + /// The methods whose reflected definitions have been written into the quotation already. The definition of a + /// method is one tree for the process, so a second call of the method needs a copy of it: the nodes of a call are + /// its own, as the values are that the call computes. + /// + let expanded = HashSet() + + /// + /// The functions that were found to call themselves, directly or through the functions they call. A call of one + /// of them stays a call. + /// + let recursive = List() + + /// + /// The nodes that stand at several places of the quotation, by their identity: the ones that it comes with, and + /// every value that was bound by or passed as an argument and is used more than once. Such + /// a node has to stay one node whatever is rewritten around it and inside it. + /// + let shared = nodesAtSeveralPlacesOf quotation + + /// + /// The normal forms of the nodes that stand at several places, by their identity, so that every place gets the + /// same one. + /// + let normalOfShared = Dictionary ReferenceEqualityComparer.Instance + + /// The number of rewriting steps taken so far. + let mutable rewrites = 0 + + /// The first error; after it nothing is rewritten any more. + let mutable failure : TranslationError voption = ValueNone + + /// Whether the error is that the quotation is nested too deeply, so that no part of it can be printed. + let mutable isTooDeep = false + + /// The error that stopped the normalization, when one did. + member _.Failure = failure + + /// The functions that the normalization found to call themselves, whose calls it left calls. + member _.Recursive : IReadOnlyList = recursive + + /// + /// The reflected definition of applied to the arguments of the call. No value when the + /// definition does not take these arguments, and none when calls itself, directly or + /// through the functions it calls. + /// + /// + /// + /// A function that calls itself is found while its definition is normalized: the definition holds a call of a + /// function whose definition is being normalized. That call stays a call, and so does the call that led to it, + /// whose normalized definition is not used. What becomes of such calls is decided when the whole quotation is + /// normalized: one that is left and reads a value of the document is the error, and one in code that never runs + /// is gone by then. + /// + /// + /// The normal form of a definition is not kept for the next call of the method. A value that the definition binds + /// and reads twice is one node at both places, which says that it is computed once; kept, it would be that one + /// node in every call, and the calls would share a value that each of them computes for itself. So every call + /// after the first normalizes a copy of the definition: + /// + /// builds every node anew, also when it replaces nothing. + /// + /// + /// The called method. + /// Its reflected definition. + /// The arguments, in the groups the definition takes them in. + member private this.Inline (method : MethodBase, definition : Expr, groups : Expr list list) : Expr voption = + if inlining |> Seq.exists (isSameDefinition method) then + recursive.Add method + ValueNone + else + let ownDefinition = + if expanded.Add method then + definition + else + definition.Substitute (fun _ -> None) + + inlining.Push method + let normalDefinition = this.Normalize ownDefinition + inlining.Pop () |> ignore + + if + failure.IsNone + && not (isAmong recursive method) + && takes normalDefinition.Type groups + then + ValueSome (Expr.Applications (normalDefinition, groups)) + else + ValueNone + + /// + /// A call of a function or method that has a reflected definition is that definition applied to the receiver and + /// the arguments of the call, unless a derived class can override the method, the definition does not take these + /// arguments, or the function calls itself. + /// + member private this.InlineCall (receiver : Expr option, method : MethodInfo, arguments : Expr list) : Expr voption = + match reflectedDefinitionOf method with + | ValueSome definition when isStaticallyBound method -> + let groups = + match receiver with + | Some receiver -> + [ receiverFor 0 definition receiver ] + :: argumentGroups method arguments + | None -> argumentGroups method arguments + + this.Inline (method, definition, groups) + | _ -> ValueNone + + /// + /// The reading of a property whose getter has a reflected definition is that definition applied to the receiver + /// and the arguments, unless a derived class can override the getter, the definition does not take these + /// arguments, or the getter calls itself. A module-level value is not such a reading: it is computed once, when + /// its module is initialized, so it stays a reference to that value. It is told from a static property by its + /// definition, which is the value and not a function of the unit value. + /// + member private this.InlineGetter (receiver : Expr option, property : PropertyInfo, arguments : Expr list) : Expr voption = + match property.GetMethod with + | null -> ValueNone + | getter -> + match reflectedDefinitionOf getter, receiver with + | ValueSome definition, Some receiver when isStaticallyBound getter -> + this.Inline (getter, definition, [ [ receiverFor 0 definition receiver ]; arguments ]) + | ValueSome definition, None when not (Type.(=) (definition.Type, property.PropertyType)) -> + this.Inline (getter, definition, [ arguments ]) + | _ -> ValueNone + + /// + /// The rewrites that look at a node before its parts are normalized, because they replace what the parts are. + /// + /// + /// + /// A quotation that carries its compiled value, which a parameter marked with + /// receives, is the + /// quotation. + /// The address of a value as the receiver of a property is the value. Only a struct anonymous + /// record is read this way, and such a node has to go first: + /// + /// refuses to rebuild it. + /// A call that passes witnesses is the call without them, or, when the called function or + /// member is and has a reflected definition, that definition applied to the witnesses, + /// the receiver and the arguments. The witnesses are functions the compiler writes for the operators of a member + /// constraint; they are not a part of what the user wrote and are not normalized. + /// + /// + member private this.RewriteBeforeParts (expr : Expr) : Expr voption = + match expr with + | WithValue (_, _, quotation) -> ValueSome quotation + | PropertyGet (Some (AddressOf receiver), property, arguments) -> + ValueSome (Expr.PropertyGet (receiver, property, arguments)) + | CallWithWitnesses (receiver, method, witnessMethod, witnesses, arguments) -> + let inlined = + match definitionWithWitnesses method witnessMethod with + | ValueSome (struct (defined, definition)) when isStaticallyBound method -> + let groups = [ + for witness in witnesses do + [ witness ] + match receiver with + | Some receiver -> [ receiverFor witnesses.Length definition receiver ] + | None -> () + yield! argumentGroups method arguments + ] + + this.Inline (defined, definition, groups) + | _ -> ValueNone + + match inlined, receiver with + | ValueSome _, _ -> inlined + | ValueNone, _ when failure.IsSome -> ValueNone + | ValueNone, Some receiver -> ValueSome (Expr.Call (receiver, method, arguments)) + | ValueNone, None -> ValueSome (Expr.Call (method, arguments)) + | _ -> ValueNone + + /// + /// One rewriting step at a node whose parts are in normal form, when a rule applies to it. + /// + /// + /// + /// A function written in place and applied in place is its body with the argument at the places + /// of the parameter. A function of a tuple that is applied to a tuple is covered by that: its body reads the items + /// of the tuple, which the rule for items takes from the tuple. + /// A is its body with the bound value at the places of the variable, + /// unless the variable is mutable and the body assigns to it. This covers the bindings the compiler writes itself: + /// the copy of a struct before a member of it is read, which is a mutable variable that nothing assigns to when the + /// member is not known to leave the struct as it is, the value a looks at, and the parts of + /// a tuple pattern. + /// The reading of an item of a tuple that is built in the same place is that item, and the test + /// for a case of a union that is built in the same place is a constant. + /// The rules for choices, for the functions of FSharp.Core, for properties of values built in + /// place and for reflected definitions are functions and members of their own. + /// + /// + member private this.Rewrite (expr : Expr) : Expr voption = + match expr with + | Application (Lambda (parameter, body), argument) -> ValueSome (bind shared parameter argument body) + | Let (variable, value, body) when not variable.IsMutable || not (isChanged variable body) -> + ValueSome (bind shared variable value body) + | IfThenElse (condition, whenTrue, whenFalse) -> canonicalChoice condition whenTrue whenFalse + | TupleGet (NewTuple items, index) -> ValueSome items[index] + | UnionCaseTest (NewUnionCase (case, _), tested) -> ValueSome (Expr.Value (case.Tag = tested.Tag)) + | Call (receiver, method, arguments) -> + match receiver, knownFunctionOf method with + | None, ValueSome known -> + eliminatePipeOrComposition known arguments + |> ValueOption.orElseWith (fun () -> eliminatePairFunction known arguments) + |> ValueOption.orElseWith (fun () -> canonicalBooleanCall known arguments) + | _ -> this.InlineCall (receiver, method, arguments) + | PropertyGet (receiver, property, arguments) -> + match receiver, arguments with + | Some built, [] -> + eliminatePropertyOfBuiltValue built property + |> ValueOption.orElseWith (fun () -> this.InlineGetter (receiver, property, arguments)) + | _ -> this.InlineGetter (receiver, property, arguments) + | _ -> ValueNone + + /// + /// with its parts in normal form; the same node when they already were. + /// + /// + /// A choice has its condition normalized first. When the condition is a constant then, the branches are left as + /// they are: the rewrite that follows takes the branch the constant chooses, and the other branch is code that + /// never runs, which may have no normal form at all. + /// + member private this.NormalizeParts (expr : Expr) : Expr = + match expr with + | IfThenElse (condition, whenTrue, whenFalse) -> + let normalCondition = this.Normalize condition + + let struct (normalWhenTrue, normalWhenFalse) = + match normalCondition with + | Constant _ -> struct (whenTrue, whenFalse) + | _ -> struct (this.Normalize whenTrue, this.Normalize whenFalse) + + if + obj.ReferenceEquals (normalCondition, condition) + && obj.ReferenceEquals (normalWhenTrue, whenTrue) + && obj.ReferenceEquals (normalWhenFalse, whenFalse) + then + expr + else + Expr.IfThenElse (normalCondition, normalWhenTrue, normalWhenFalse) + | ShapeVar _ -> expr + | ShapeLambda (parameter, body) -> + let normalBody = this.Normalize body + + if obj.ReferenceEquals (normalBody, body) then + expr + else + Expr.Lambda (parameter, normalBody) + | ShapeCombination (shape, parts) -> + let normalParts = parts |> List.map this.Normalize + + if areSame parts normalParts then + expr + else + RebuildShapeCombination (shape, normalParts) + + /// + /// The normal form of , or any quotation and a + /// . + /// + /// + /// A node that stands at several places is normalized at the first of them, and the other places get the same + /// normal form: normalizing it again at every place would give every place a node of its own. + /// + member this.Normalize (expr : Expr) : Expr = + if shared.Count > 0 && shared.Contains expr then + match normalOfShared.TryGetValue expr with + | true, normal -> normal + | _ -> + let normal = this.NormalizeAnew expr + + if failure.IsNone then + normalOfShared.Add (expr, normal) + + // The normal form stands at those places from now on, and it is its own normal form. + if shared.Add normal then + normalOfShared.Add (normal, normal) + + normal + else + this.NormalizeAnew expr + + /// + /// The normal form of , worked out now, or any quotation and a + /// . + /// + /// + /// + /// The parts of a node are normalized first, then the node is rewritten, and what a rewrite gives is normalized + /// again, in a loop: a quotation that has no normal form would otherwise use up the stack before it uses up + /// . + /// + /// + /// When the parts of a node fail and the node is a construct that a query cannot express whatever is inside it, + /// the node is the failure. So the outermost such construct is reported, as it is when nothing fails inside it. + /// A quotation that is nested too deeply stays the failure whatever stands around it: the error of a construct + /// shows the construct, and nothing that deep can be printed with the stack that is left. + /// + /// + member private this.NormalizeAnew (expr : Expr) : Expr = + let mutable current = expr + let mutable isNormal = false + + while not isNormal && failure.IsNone do + if not (RuntimeHelpers.TryEnsureSufficientExecutionStack ()) then + failure <- ValueSome nestedTooDeeply + isTooDeep <- true + else + let rewritten = + match this.RewriteBeforeParts current with + | ValueSome _ as rewritten -> rewritten + | ValueNone when failure.IsSome -> ValueNone + | ValueNone -> + let node = current + current <- this.NormalizeParts node + + if failure.IsSome then + if not isTooDeep then + failure <- neverExpressed node |> ValueOption.orElse failure + + ValueNone + else + this.Rewrite current + + match rewritten with + | ValueSome next when rewrites < MaxRewrites -> + rewrites <- rewrites + 1 + current <- next + | ValueSome _ -> failure <- ValueSome tooManyRewrites + | ValueNone -> isNormal <- true + + current + +/// The function at the head of a chain of applications: what is applied to the first argument. +let rec private appliedFunction (expr : Expr) : Expr = + match expr with + | Application (func, _) -> appliedFunction func + | _ -> expr + +/// +/// The error for a function that is applied to a value of the document and is not written in the quotation. +/// +/// +/// A function that reads no variable of the quotation is a compiled value that the quotation has captured, however +/// the quotation gets to it: by its name, or from a property or a field of a captured value. What a call returns is +/// compiled whatever the call is given, because it is the definition of the called function that cannot be read. Any +/// other function that reads a variable is chosen or computed for every document. +/// +let private appliedFunctionValue (application : Expr) : TranslationError = + let applied = appliedFunction application + + let compiledFunction = + match applied with + | Call (_, method, _) -> ValueSome $"The function that '%s{method.Name}' returns" + | _ when not (Seq.isEmpty (applied.GetFreeVars ())) -> ValueNone + | ValueWithName (_, _, name) -> ValueSome $"The function '%s{name}'" + | PropertyGet (_, property, _) -> ValueSome $"The function '%s{property.Name}'" + | FieldGet (_, field) -> ValueSome $"The function '%s{field.Name}'" + | _ -> ValueSome "A function" + + match compiledFunction with + | ValueSome compiledFunction -> + application + |> TranslationError.ofQuotation + TranslationErrorCode.CapturedFunctionValue + $"%s{compiledFunction} is a compiled value and is applied to a value of the document. A query cannot apply it, because its definition cannot be read." + (ImmutableArray.Create( + "Mark the function with [], so that its definition can be read.", + "Or write the condition as a quotation and splice it into the query with %." + )) + | ValueNone -> + application + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + "A function that is chosen or computed when the query runs is applied to a value of the document. A query can apply only a function whose definition is written in the quotation." + ImmutableArray.Empty + +/// +/// The error for when it is a construct that a query cannot express, whatever its parts are. +/// +/// +/// An application of a function that is not written in the quotation is an error only when it depends on a variable +/// of the quotation, which is how a value of the document is reached. Without one it is a value like any other captured +/// value, and the stage that computes such values outside the query computes it. The same holds for a call of a +/// function that calls itself, which the normalization left a call: the compiled function computes such a value. +/// +/// The functions that the normalization found to call themselves. +/// A part of a quotation in normal form. +let private residueAt (recursive : IReadOnlyList) (expr : Expr) : TranslationError voption = + let readsDocument () = not (Seq.isEmpty (expr.GetFreeVars ())) + + let callsItself (method : MethodBase | null) = + match method with + | null -> false + | method -> isAmong recursive method + + match expr with + | Application _ when readsDocument () -> ValueSome (appliedFunctionValue expr) + | Call (_, method, _) when callsItself method && readsDocument () -> + ValueSome (recursiveDefinition $"The function '%s{method.Name}'" expr) + | PropertyGet (_, property, _) when callsItself property.GetMethod && readsDocument () -> + ValueSome (recursiveDefinition $"The property '%s{property.Name}'" expr) + | Let _ -> + expr + |> unsupported "a mutable variable that is assigned to" "Bind every value once, with an immutable let." + |> ValueSome + | AddressOf _ -> + expr + |> unsupported "the address of a value" "Read the value itself." + |> ValueSome + | _ -> neverExpressed expr + +/// +/// The first part of a quotation in normal form that a query cannot express, as an error; an outer part before the +/// parts inside it. +/// +let rec private findResidue (recursive : IReadOnlyList) (expr : Expr) : TranslationError voption = + match expr with + | ShapeVar _ -> ValueNone + | ShapeLambda (_, body) -> findResidue recursive body + | ShapeCombination (_, parts) -> + residueAt recursive expr + |> ValueOption.orElseWith (fun () -> parts |> List.tryPick (findResidue recursive)) + +/// +/// The normal form of , or the reason it has none that a query can express. +/// +/// +/// +/// The normal form computes what computes, as long as the code in it has no side effects: a +/// value bound by is written at every place it is used, and a bound value or a part of a tuple +/// or record that nothing reads is dropped with its code. An exception is such an effect: code that is dropped raises +/// none, and code that is written at the places of its variable runs where they are. +/// +/// +/// These are errors: +/// +/// +/// a call of a function with a reflected definition that calls itself, when the call reads a value +/// of the document, and a quotation whose simplification does not end, +/// ; +/// a function that is a compiled value and is applied to a value of the document, +/// ; +/// a recursive function, a mutable variable that is assigned to, the address of a value, a sequence of +/// statements, a loop and exception handling, +/// . +/// +/// +/// Of the constructs that stay in the normal form, the outermost one is the error. A recursive function, an assignment, +/// a sequence of statements, a loop and exception handling are errors whatever is inside them, so the outermost of +/// these is the error also when the quotation inside it has no normal form at all. +/// +/// +/// Only what stays is an error. Code that never runs is not in the normal form, so it may hold any of these: the +/// branch that a constant condition does not choose, also when the constant gets to the condition through a +/// , a parameter or a reflected definition. What cannot be told that way is a quotation whose +/// simplification does not end, which stops the normalization where it is met. +/// +/// +let normalize (expr : Expr) : Result = + let normalization = Normalization expr + let normal = normalization.Normalize expr + + match + normalization.Failure + |> ValueOption.orElseWith (fun () -> findResidue normalization.Recursive normal) + with + | ValueSome failure -> Error failure + | ValueNone -> Ok normal From 6902cc4e49c354d366a9140ca03e913b4e63afd4 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Mon, 12 Oct 2026 10:22:33 +0200 Subject: [PATCH 03/10] test(quotations): cover the normalizer A new test project, FSharp.Azure.Cosmos.Quotations.Tests, with unit tests that need no emulator. Most tests are pairs: one way to write a function next to the plain way to write the same function. For every pair three things are checked: both ways have one normal form, the normal form is returned as the same node when it is normalized again, and it computes what the compiled code computes on sample values. The compiled code and the quotation come from one lambda, which the compiler passes both ways to a parameter marked with ReflectedDefinition(true), and Unquote evaluates the quotation. The other tests state what a pair cannot: what must stay as it is, what must be gone, how one variable that is bound at two nested places is treated, that a value which is bound once stays one node at all its places, and so does a quotation that is spliced into two places, what every error says and which of several errors is reported. The test project is compiled with --quotations-debug, so the errors carry the place in the source; a quotation built through the API covers the case without one. Co-Authored-By: Claude Opus 5.5 --- .github/copilot-instructions.md | 1 + FSharp.Azure.Cosmos.slnf | 1 + FSharp.Azure.Cosmos.slnx | 1 + .../FSharp.Azure.Cosmos.Quotations.fsproj | 1 + src/Cosmos.Quotations/InternalsVisibleTo.fs | 9 + ...Sharp.Azure.Cosmos.Quotations.Tests.fsproj | 46 ++ tests/Cosmos.Quotations.Tests/Model.fs | 294 +++++++++ .../NormalizerErrorTests.fs | 567 ++++++++++++++++++ .../NormalizerSpellingTests.fs | 567 ++++++++++++++++++ .../NormalizerTests.fs | 435 ++++++++++++++ .../QuotationAssert.fs | 177 ++++++ .../Cosmos.Quotations.Tests/TestCategories.fs | 18 + tests/Cosmos.Quotations.Tests/testconfig.json | 9 + 13 files changed, 2126 insertions(+) create mode 100644 src/Cosmos.Quotations/InternalsVisibleTo.fs create mode 100644 tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj create mode 100644 tests/Cosmos.Quotations.Tests/Model.fs create mode 100644 tests/Cosmos.Quotations.Tests/NormalizerErrorTests.fs create mode 100644 tests/Cosmos.Quotations.Tests/NormalizerSpellingTests.fs create mode 100644 tests/Cosmos.Quotations.Tests/NormalizerTests.fs create mode 100644 tests/Cosmos.Quotations.Tests/QuotationAssert.fs create mode 100644 tests/Cosmos.Quotations.Tests/TestCategories.fs create mode 100644 tests/Cosmos.Quotations.Tests/testconfig.json diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index 6e8dbb54..da701b94 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -31,6 +31,7 @@ ├── src/Shared/ – source files that every F# project under src and tests compiles │ └── ValueCollections.fs – `Seq`, `List` and `Array` functions that return `voption` and struct tuples ├── tests/Cosmos.Tests/ – MSTest integration test project +├── tests/Cosmos.Quotations.Tests/ – MSTest unit tests of FSharp.Azure.Cosmos.Quotations, no emulator needed ├── tests/Cosmos.Tests.Infrastructure/ – shared test fixtures, emulator settings and assertion helpers ├── build/ – FAKE build scripts └── docsSrc/ – FSharp.Formatting documentation source diff --git a/FSharp.Azure.Cosmos.slnf b/FSharp.Azure.Cosmos.slnf index 5f77075d..bb4984ca 100644 --- a/FSharp.Azure.Cosmos.slnf +++ b/FSharp.Azure.Cosmos.slnf @@ -4,6 +4,7 @@ "projects": [ "src\\Cosmos.Quotations\\FSharp.Azure.Cosmos.Quotations.fsproj", "src\\Cosmos\\FSharp.Azure.Cosmos.fsproj", + "tests\\Cosmos.Quotations.Tests\\FSharp.Azure.Cosmos.Quotations.Tests.fsproj", "tests\\Cosmos.Tests.Infrastructure\\FSharp.Azure.Cosmos.Tests.Infrastructure.fsproj", "tests\\Cosmos.Tests\\FSharp.Azure.Cosmos.Tests.fsproj" ] diff --git a/FSharp.Azure.Cosmos.slnx b/FSharp.Azure.Cosmos.slnx index 19bc8997..3b8b2185 100644 --- a/FSharp.Azure.Cosmos.slnx +++ b/FSharp.Azure.Cosmos.slnx @@ -12,6 +12,7 @@ + diff --git a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj index 839b1b02..acda5228 100644 --- a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj +++ b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj @@ -20,6 +20,7 @@ + diff --git a/src/Cosmos.Quotations/InternalsVisibleTo.fs b/src/Cosmos.Quotations/InternalsVisibleTo.fs new file mode 100644 index 00000000..f9f7880d --- /dev/null +++ b/src/Cosmos.Quotations/InternalsVisibleTo.fs @@ -0,0 +1,9 @@ +// The stages of the translator are internal: a consumer sees the translator as a whole. Their tests call each stage +// directly, so the test assembly sees the internals. AssemblyInfo.fs cannot hold the attribute, because FAKE rewrites +// that file for every release. +namespace FSharp.Azure.Cosmos.Quotations + +open System.Runtime.CompilerServices + +[] +do () diff --git a/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj b/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj new file mode 100644 index 00000000..1148efef --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj @@ -0,0 +1,46 @@ + + + + + net10.0 + $(AssemblyBaseName).Quotations.Tests + + Exe + true + + + $(OtherFlags) --quotations-debug+ + + + + + PreserveNewest + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/Cosmos.Quotations.Tests/Model.fs b/tests/Cosmos.Quotations.Tests/Model.fs new file mode 100644 index 00000000..32480723 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/Model.fs @@ -0,0 +1,294 @@ +// The types and functions that the tests of the normalizer write their quotations over. They are made for the +// normalizer: every kind of function whose definition it can read is here once, next to functions it cannot read. +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System.Collections.Immutable + +/// A range of ages; a record that tests build in place and read a field of. +type AgeRange = { Low : int; High : int } + +/// A way to choose persons; a union that tests build in place and match on. +type PersonFilter = + /// The persons with this name. + | ByName of name : string + /// The persons older than this age. + | OlderThan of age : int + +/// A person, the document most quotations of the tests are written over. +type Person = { + Name : string + Age : int + Active : bool + Nick : string option + Tags : string list + /// The best and the worst score, a tuple that is a part of the document. + Scores : int * int +} with + + /// A method with a reflected definition. + [] + member this.IsOlderThan (age : int) = this.Age > age + + /// A method of two arguments, which its definition takes as one tuple. + [] + member this.IsBetween (low : int, high : int) = this.Age >= low && this.Age <= high + + /// A curried method. + [] + member this.IsWithin (low : int) (high : int) = this.Age >= low && this.Age <= high + + /// A property with a reflected definition. + [] + member this.IsAdult = this.Age >= 18 + + /// An inline method with an operator of a member constraint: the compiler passes it the person as the receiver + /// and the addition as a witness. + [] + member inline this.IsOlderThanTwice limit = this.Age > limit + limit + + /// A static method with a reflected definition. + [] + static member IsNamed (name : string, person : Person) = person.Name = name + + /// An inline static method with an operator of a member constraint. + [] + static member inline Doubled value = value + value + + /// A method without a reflected definition: a call of it stays a call. + member this.IsRetired () = this.Age >= 65 + +/// The base of a class hierarchy, whose members are defined for the base class and called on a derived one. +[] +type DocumentBase (id : string) = + + /// The id of the document. + member _.Id = id + + /// A method of the base class with a reflected definition. + [] + member this.HasId (expected : string) = this.Id = expected + + /// A property of the base class with a reflected definition. + [] + member this.IsIdentified = this.Id <> "" + + /// A member that a derived class can override. + abstract Describe : unit -> string + + /// The definition of the member for the documents that do not override it. It has a reflected definition, which + /// says nothing about a document that does. + [] + default this.Describe () = "document " + this.Id + +/// A derived class. +type Invoice (id : string, total : int) = + inherit DocumentBase (id) + + /// The total of the invoice. + member _.Total = total + + /// A static property with a reflected definition: its getter runs on every reading, unlike a module-level value. + [] + static member LargeTotal = 100 + + /// An invoice describes itself in its own way. + override this.Describe () = "invoice " + this.Id + + /// A property of a struct type on a class: to call a member of its value, the compiler binds a copy of the value to + /// a mutable variable. + member val Note : string voption = ValueNone with get, set + +/// A class with a property that can be set: an assignment is something a query cannot express. +type Counter () = + + /// The count. + member val Count = 0 with get, set + +/// A type that can apply itself, which gives a quotation that has no normal form without any recursive function. +type Loop = Loop of (Loop -> bool) + +/// A folder in a tree of folders. +type Folder = { + Name : string + Parent : Folder option +} with + + /// A property with a reflected definition that reads itself, of the parent. + [] + member this.Depth : int = + match this.Parent with + | Some parent -> parent.Depth + 1 + | None -> 0 + +/// +/// Members added to outside its definition: the compiler +/// makes them static methods that take the person first. +/// +[] +module PersonExtensions = + + type Person with + + /// An extension method with a reflected definition. + [] + member this.IsYoungerThan (age : int) = this.Age < age + + /// An extension method of two arguments. + [] + member this.IsOutside (low : int, high : int) = this.Age < low || this.Age > high + + /// An extension property with a reflected definition. + [] + member this.HasNick = this.Nick.IsSome + + /// A static extension property with a reflected definition. + [] + static member AdultAge = 18 + +/// Functions over the model: with a reflected definition, which the normalizer writes into the quotation, and without. +module Conditions = + + /// A function of one argument. + [] + let isAdult (person : Person) = person.Age >= 18 + + /// A curried function. + [] + let isOlderThan (age : int) (person : Person) = person.Age > age + + /// A function whose first argument is a tuple. + [] + let isBetween (low : int, high : int) (person : Person) = person.Age >= low && person.Age <= high + + /// A function whose only argument is a tuple. + [] + let isNamed (name : string, person : Person) = person.Name = name + + /// A function of the unit value. + [] + let adultAge () = 18 + + /// A generic function. + [] + let hasValue (value : 'T option) = value.IsSome + + /// An inline function with an operator of a member constraint: the compiler passes it the addition as a witness. + [] + let inline twice value = value + value + + /// A function that binds a value which no document gives and reads it twice: a call computes the value once, and + /// every call computes it for itself. + [] + let isWithinProcessors (person : Person) = + let processors = System.Environment.ProcessorCount + person.Age > processors && person.Age < processors * 10 + + /// A function that calls other functions with reflected definitions. + [] + let isWorkingAge (person : Person) = isAdult person && not (person |> isOlderThan 64) + + /// A function that takes a function and applies it under a function of its own. + [] + let hasTagThat (predicate : string -> bool) (person : Person) = person.Tags |> List.exists (fun tag -> predicate tag) + + /// A function that reads a struct anonymous record, which the compiler does through the address of the record. + [] + let isOlderThanMinimum (limits : struct {| MinAge : int |}) (person : Person) = person.Age > limits.MinAge + + /// A function that matches on a union, which a caller usually builds in place. + [] + let satisfies (filter : PersonFilter) (person : Person) = + match filter with + | ByName name -> person.Name = name + | OlderThan age -> person.Age > age + + /// A function that calls itself. + [] + let rec factorial (number : int) : int = if number <= 1 then 1 else number * factorial (number - 1) + + /// A function that chooses between a condition and one that calls a function which calls itself. With a constant + /// for its first argument, one of the two is code that never runs. + [] + let isActiveOrCounted (onlyActive : bool) (person : Person) = + if onlyActive then + person.Active + else + factorial person.Age > 0 + + /// A function that calls itself through another function. + [] + let rec isEven (number : int) : bool = number = 0 || isOdd (number - 1) + + /// The other function of the pair. + and [] isOdd (number : int) : bool = number <> 0 && isEven (number - 1) + + /// A module-level value with a reflected definition. It is computed once, when the module is initialized, so the + /// normalizer leaves it a reference. + [] + let retirementAge = 65 + + /// A module-level value that is a function of the unit value. The definition of a static property is such a + /// function too, but this one is the value itself: the binding before the function keeps the compiler from making + /// a function of the module of it. + [] + let earlyRetirementAge : unit -> int = + let age = retirementAge - 5 + fun () -> age + + /// A function without a reflected definition: a call of it stays a call. + let isTeenager (person : Person) = person.Age >= 13 && person.Age <= 19 + + /// A function without a reflected definition that returns a function. The binding before the function keeps the + /// compiler from making one function of two arguments of it. + let olderThan (age : int) : Person -> bool = + let limit = age + fun person -> person.Age > limit + + /// A module-level value that is a function: the result of a call, so there is no definition to read. + let isSenior : Person -> bool = olderThan 59 + +/// The persons that the tests evaluate quotations on. +module Persons = + + /// A child without a nickname and without tags. + let child = { + Name = "Ann" + Age = 9 + Active = true + Nick = None + Tags = [] + Scores = (3, 1) + } + + /// An adult with a nickname and tags. + let adult = { + Name = "Bob" + Age = 30 + Active = false + Nick = Some "bobby" + Tags = [ "vip"; "" ] + Scores = (10, 7) + } + + /// A person exactly at the age of majority. + let eighteen = { + Name = "Cy" + Age = 18 + Active = true + Nick = Some "" + Tags = [ "new" ] + Scores = (0, 0) + } + + /// A retired person. + let retired = { + Name = "Dee" + Age = 70 + Active = false + Nick = None + Tags = [ "vip" ] + Scores = (65, 2) + } + + /// Every person above. + let all = ImmutableArray.Create (child, adult, eighteen, retired) diff --git a/tests/Cosmos.Quotations.Tests/NormalizerErrorTests.fs b/tests/Cosmos.Quotations.Tests/NormalizerErrorTests.fs new file mode 100644 index 00000000..902a511d --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/NormalizerErrorTests.fs @@ -0,0 +1,567 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations +open FSharp.Quotations.Patterns + +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// +/// The quotations that have no normal form a query can express, and what the +/// says about each. +/// +[] +type NormalizerErrorTests () = + + static let unsupportedConstructs = + let mutableVariable = Var ("count", typeof, true) + let variable = Var ("value", typeof) + + seq { + struct ("a mutable variable that is assigned to", + <@@ + fun (p : Person) -> + let mutable age = p.Age + age <- age + 1 + age > 18 + @@>, + "a mutable variable") + struct ("an assignment to a property", <@@ fun (counter : Counter) -> counter.Count <- 1 @@>, "an assignment") + struct ("an assignment to a variable", Expr.VarSet (mutableVariable, <@@ 1 @@>), "an assignment") + struct ("a sequence of statements", + <@@ + fun (p : Person) -> + ignore p.Age + p.Active + @@>, + "a sequence of statements") + struct ("a for loop", + <@@ + fun (p : Person) -> + for index in 1 .. p.Age do + ignore index + @@>, + "a loop") + struct ("a while loop", + <@@ + fun (p : Person) -> + while p.Active do + () + @@>, + "a loop") + struct ("a handler of exceptions", + <@@ + fun (p : Person) -> + try + p.Active + with _ -> + false + @@>, + "exception handling") + struct ("a finally block", + <@@ + fun (p : Person) -> + try + p.Active + finally + () + @@>, + "exception handling") + struct ("a recursive function written in place", + <@@ + fun (p : Person) -> + let rec countTo (number : int) : int = if number >= p.Age then number else countTo (number + 1) + countTo 0 > 5 + @@>, + "a recursive function") + struct ("the address of a value", Expr.Lambda (variable, Expr.AddressOf (Expr.Var variable)), "the address of a value") + } + |> ImmutableArray.CreateRange + + /// + /// Every construct that a query cannot express, with the words the message has to name it by. The name of a row + /// replaces the name of the test method in the results, so it says what is asserted. + /// + static member UnsupportedConstructs : IEnumerable> = + unsupportedConstructs + |> Seq.map (fun (struct (name, quotation, words)) -> + TestDataRow( + struct (quotation, words), + DisplayName = $"%s{name} must be reported as unsupported and named" + ) + ) + + [] + member _.``A construct that a query cannot express must be reported as unsupported and named`` + (quotation : Expr, words : string) + = + let error = NormalizerAssert.WantError quotation + + Assert.AreEqual( + TranslationErrorCode.Unsupported, + error.Code, + "The construct has no counterpart in a query." + ) + Assert.Contains (words, error.Message, StringComparison.Ordinal, "The message should name the construct.") + Assert.IsNotEmpty (error.Hints, "The error should say what to write instead.") + + [] + member _.``A construct that a query cannot express must be reported when the quotation inside it has no normal form`` () = + // Two errors, one inside the other: a loop, and in its condition a function that calls itself. + let loop = + NormalizerAssert.WantError + <@ + fun (p : Person) -> + while Conditions.factorial p.Age > 100 do + () + @> + + Assert.AreEqual( + TranslationErrorCode.Unsupported, + loop.Code, + "The loop is the outer of the two errors, and nothing inside it can make a query of it." + ) + Assert.Contains ("a loop", loop.Message, StringComparison.Ordinal, "The message should name the loop.") + + // Three errors: the statements of the body are the outermost one, then the loop, then the function. + let statements = + NormalizerAssert.WantError + <@ + fun (p : Person) -> + while Conditions.factorial p.Age > 100 do + () + + p.Active + @> + + Assert.Contains ( + "a sequence of statements", + statements.Message, + StringComparison.Ordinal, + "The message should name the outermost construct that a query cannot express." + ) + + // The call of such a function stays in the normal form, where the outermost construct is the error. A + // condition whose simplification has no end stops the normalization where it is met, inside the loop, and the + // loop is the error all the same. + let endless : Expr = + <@ + let self = + fun (loop : Loop) -> + match loop with + | Loop apply -> apply loop + + self (Loop self) + @> + + let endlessLoop = + NormalizerAssert.WantError + <@ + fun (p : Person) -> + while %endless do + () + @> + + Assert.Contains ( + "a loop", + endlessLoop.Message, + StringComparison.Ordinal, + "The message should name the loop, and not what stopped the normalization inside it." + ) + + let endlessStatements = + NormalizerAssert.WantError + <@ + fun (p : Person) -> + while %endless do + () + + p.Active + @> + + Assert.Contains ( + "a sequence of statements", + endlessStatements.Message, + StringComparison.Ordinal, + "The message should name the outermost construct, and not the loop inside it." + ) + + [] + member _.``A mutable variable must be reported at the binding that is assigned to when an outer binding has the same variable`` + () + = + // One mutable variable that two bindings bind, one inside the other; only the inner one is assigned to. + // fun p -> let mutable count = 111 in (let mutable count = 222 in count <- 333; count > p.Age) + let count = Var ("count", typeof, true) + let person = Var ("p", typeof) + + let inner = + Expr.Let ( + count, + <@@ 222 @@>, + Expr.Sequential ( + Expr.VarSet (count, <@@ 333 @@>), + <@@ %%(Expr.Var count) > (%%(Expr.Var person) : Person).Age @@> + ) + ) + + let error = NormalizerAssert.WantError (Expr.Lambda (person, Expr.Let (count, <@@ 111 @@>, inner))) + + Assert.Contains ( + "a mutable variable", + error.Message, + StringComparison.Ordinal, + "The inner binding is assigned to, which a query cannot express." + ) + Assert.Contains ("222", error.Fragment, StringComparison.Ordinal, "The fragment should be the inner binding.") + Assert.DoesNotContain ( + "111", + error.Fragment, + StringComparison.Ordinal, + "Nothing assigns to the outer binding, so it should be gone: the inner binding hides the variable." + ) + + [] + member _.``A captured function that is applied to the document must be reported with its name and advice`` () = + let isVip = fun (p : Person) -> p.Tags |> List.contains "vip" + let error = NormalizerAssert.WantError <@ fun (p : Person) -> p.Active && isVip p @> + + Assert.AreEqual( + TranslationErrorCode.CapturedFunctionValue, + error.Code, + "A compiled function cannot be read, so it cannot be applied in a query." + ) + + Assert.Contains ("'isVip'", error.Message, StringComparison.Ordinal, "The message should name the function.") + Assert.Contains ( + "isVip", + error.Fragment, + StringComparison.Ordinal, + "The fragment should be the application of the function." + ) + Assert.HasCount (2, error.Hints, "The error should offer the reflected definition and the spliced quotation.") + + [] + member _.``An error must point at the place in the source when the compiler recorded it`` () = + let isVip = fun (p : Person) -> p.Tags |> List.contains "vip" + let error = NormalizerAssert.WantError <@ fun (p : Person) -> isVip p @> + let location = + Assert.WantValueSome ( + error.Location, + "The tests are compiled with --quotations-debug, so the quotation has its place." + ) + + Assert.EndsWith ("NormalizerErrorTests.fs", location.File, StringComparison.Ordinal, "The place should be in this file.") + Assert.IsGreaterThan (0, location.StartLine, "The first line of a file is 1.") + Assert.IsGreaterThanOrEqualTo (location.StartLine, location.EndLine, "A range does not end before it starts.") + + [] + member _.``An error about a quotation that was built through the API must have no place in the source`` () = + let variable = Var ("value", typeof) + let error = NormalizerAssert.WantError (Expr.Lambda (variable, Expr.AddressOf (Expr.Var variable))) + + Assert.IsValueNone (error.Location, "The compiler never saw the quotation, so it recorded no place.") + + [] + member _.``A function that a call returns must be reported as a compiled function when it is applied to the document`` () = + let error = NormalizerAssert.WantError <@ fun (p : Person) -> Conditions.olderThan 18 p @> + + Assert.AreEqual( + TranslationErrorCode.CapturedFunctionValue, + error.Code, + "What the call returns is a compiled function." + ) + Assert.Contains ( + "'olderThan'", + error.Message, + StringComparison.Ordinal, + "The message should name the function that returns it." + ) + + // The same holds when the call is given a value of the document: it is the definition of the called function + // that cannot be read, and the advice is to make it readable. + let ofDocument = NormalizerAssert.WantError <@ fun (p : Person) -> Conditions.olderThan p.Age p @> + + Assert.AreEqual( + TranslationErrorCode.CapturedFunctionValue, + ofDocument.Code, + "What the call returns is a compiled function, whatever the call is given." + ) + Assert.Contains ( + "'olderThan'", + ofDocument.Message, + StringComparison.Ordinal, + "The message should name the function that returns it, also when it is given a value of the document." + ) + + [] + member _.``A function that a captured value holds must be reported as a compiled function when it is applied to the document`` + () + = + let rules = {| IsListed = fun (p : Person) -> p.Active |} + let ofProperty = NormalizerAssert.WantError <@ fun (p : Person) -> rules.IsListed p @> + + Assert.AreEqual( + TranslationErrorCode.CapturedFunctionValue, + ofProperty.Code, + "The property of the captured value holds a compiled function." + ) + Assert.Contains ("'IsListed'", ofProperty.Message, StringComparison.Ordinal, "The message should name the property.") + Assert.HasCount (2, ofProperty.Hints, "The error should offer the reflected definition and the spliced quotation.") + + // A field of a captured value, which only code builds a reading of: F# reads the item of a struct tuple by a + // pattern. + let pair = struct ((fun (p : Person) -> p.Active), 0) + let person = Var ("p", typeof) + + let ofField = + Expr.Lambda ( + person, + Expr.Application (Expr.FieldGet (Expr.Value pair, nonNull (pair.GetType().GetField "Item1")), Expr.Var person) + ) + |> NormalizerAssert.WantError + + Assert.AreEqual( + TranslationErrorCode.CapturedFunctionValue, + ofField.Code, + "The field of the captured value holds a compiled function." + ) + Assert.Contains ("'Item1'", ofField.Message, StringComparison.Ordinal, "The message should name the field.") + + [] + member _.``A function that the document chooses must be reported as one that is chosen when the query runs`` () = + let isVip = fun (p : Person) -> p.Tags |> List.contains "vip" + let isAdult = fun (p : Person) -> p.Age >= 18 + let error = NormalizerAssert.WantError <@ fun (p : Person) -> (if p.Active then isVip else isAdult) p @> + + Assert.AreEqual( + TranslationErrorCode.Unsupported, + error.Code, + "Which function is applied depends on the document, so no advice about one compiled function fits." + ) + Assert.Contains ( + "chosen or computed when the query runs", + error.Message, + StringComparison.Ordinal, + "The message should say that the function is chosen for every document." + ) + + [] + member _.``A module-level function value must be reported as a compiled function when it is applied to the document`` () = + let error = NormalizerAssert.WantError <@ fun (p : Person) -> Conditions.isSenior p @> + + Assert.AreEqual( + TranslationErrorCode.CapturedFunctionValue, + error.Code, + "The value is a compiled function." + ) + Assert.Contains ("'isSenior'", error.Message, StringComparison.Ordinal, "The message should name the value.") + + [] + member _.``A captured function must be reported when a function with a reflected definition applies it to the document`` () = + let isLong = fun (tag : string) -> tag.Length > 3 + let error = NormalizerAssert.WantError <@ fun (p : Person) -> p |> Conditions.hasTagThat isLong @> + + Assert.AreEqual( + TranslationErrorCode.CapturedFunctionValue, + error.Code, + "The definition is written into the quotation, and there the captured function is applied to a tag of the document." + ) + + Assert.Contains ("'isLong'", error.Message, StringComparison.Ordinal, "The message should name the function.") + + [] + member _.``A composition with a captured function must be reported`` () = + let isVip = fun (p : Person) -> p.Tags |> List.contains "vip" + let error = NormalizerAssert.WantError <@ isVip >> not @> + + Assert.AreEqual( + TranslationErrorCode.CapturedFunctionValue, + error.Code, + "The composition applies the captured function to its parameter, which is the document." + ) + + [] + member _.``A captured function that is applied to captured values only must stay an application`` () = + let addOne = fun (number : int) -> number + 1 + let normal = NormalizerAssert.WantNormal <@ fun (p : Person) -> p.Age > addOne 17 @> + + let isApplication (expr : Expr) = + match expr with + | Application _ -> true + | _ -> false + + Assert.IsTrue ( + Quotation.exists isApplication normal, + "The application does not depend on the document: it is a value to compute outside the query, not an error." + ) + + [] + member _.``A function with a reflected definition that calls itself must be reported instead of followed without end`` () = + let error = NormalizerAssert.WantError <@ fun (p : Person) -> Conditions.factorial p.Age > 100 @> + + Assert.AreEqual( + TranslationErrorCode.NormalizationDiverged, + error.Code, + "A recursive definition has no end." + ) + Assert.Contains ( + "'factorial'", + error.Message, + StringComparison.Ordinal, + "The message should name the recursive function." + ) + Assert.IsNotEmpty (error.Hints, "The error should say what to write instead.") + + Assert.Contains ( + "Age", + error.Fragment, + StringComparison.Ordinal, + "The error should show the call as the quotation has it, with the argument it passes." + ) + + [] + member _.``The first of two functions that call themselves must be reported`` () = + let error = + NormalizerAssert.WantError <@ fun (p : Person) -> Conditions.isEven p.Age && Conditions.factorial p.Age > 100 @> + + Assert.Contains ( + "'isEven'", + error.Message, + StringComparison.Ordinal, + "Both calls stay in the normal form, and the first of them is the error." + ) + + [] + member _.``A property with a reflected definition that reads itself must be reported by its name`` () = + let error = NormalizerAssert.WantError <@ fun (folder : Folder) -> folder.Depth > 2 @> + + Assert.AreEqual( + TranslationErrorCode.NormalizationDiverged, + error.Code, + "A definition that reads itself has no end." + ) + Assert.Contains ( + "The property 'Depth'", + error.Message, + StringComparison.Ordinal, + "The message should name the property as it is written, and not its getter." + ) + + [] + member _.``A call of a function that calls itself must stay a call when it reads nothing of the document`` () = + let normal = NormalizerAssert.WantNormal <@ fun (p : Person) -> p.Age > Conditions.factorial 5 @> + + NormalizerAssert.AreEquivalent + <@ fun (p : Person) -> p.Age > Conditions.factorial 5 @> + normal + "The call is a value to compute outside the query, as a call of any compiled function is: it stays as it is written, and its definition is not written into the quotation once." + + let root = { Name = "root"; Parent = None } + let folder = { Name = "folder"; Parent = Some root } + + NormalizerAssert.AreEquivalent + <@ fun (p : Person) -> p.Age > folder.Depth @> + (NormalizerAssert.WantNormal <@ fun (p : Person) -> p.Age > folder.Depth @>) + "The same holds for a property that reads itself." + + [] + member _.``Functions with reflected definitions that call each other must be reported instead of followed without end`` () = + let error = NormalizerAssert.WantError <@ fun (p : Person) -> Conditions.isEven p.Age @> + + Assert.AreEqual( + TranslationErrorCode.NormalizationDiverged, + error.Code, + "Mutually recursive definitions have no end." + ) + Assert.Contains ( + "'isEven'", + error.Message, + StringComparison.Ordinal, + "The message should name the function that is called again." + ) + + [] + member _.``A quotation without a normal form must be reported when the limit of rewriting steps is reached`` () = + // The function applies the function inside its argument to that argument, and its argument holds the function + // itself: every rewriting step gives the quotation it started from. + let error = + NormalizerAssert.WantError + <@ + let self = + fun (loop : Loop) -> + match loop with + | Loop apply -> apply loop + + self (Loop self) + @> + + Assert.AreEqual(TranslationErrorCode.NormalizationDiverged, error.Code, "The rewriting has no end.") + Assert.Contains ( + "rewriting steps", + error.Message, + StringComparison.Ordinal, + "The message should say that the limit of steps was reached." + ) + Assert.AreEqual("", error.Fragment, "The error is about the quotation as a whole.") + + [] + [] + [] + member _.``A quotation that is nested too deeply must be reported`` (insideStatements : bool) = + // A tree that only code builds: a negation inside a negation, a hundred thousand deep. Nothing may walk it to + // its end, which takes more stack than a thread has. + let negation = + match <@@ not true @@> with + | Call (None, negation, _) -> negation + | other -> raise (AssertFailedException $"A negation should be a call of a function: %A{other}") + + let nested = + seq { 1..100_000 } + |> Seq.fold (fun (inner : Expr) _ -> Expr.Call (negation, [ inner ])) <@@ true @@> + + // The error of a sequence of statements shows the statements, which would walk the tree to print it. So what + // is nested too deeply has to stay the error there. + let quotation = + if insideStatements then + Expr.Sequential (Expr.Sequential (nested, <@@ () @@>), <@@ true @@>) + else + nested + + let error = NormalizerAssert.WantError quotation + + Assert.AreEqual( + TranslationErrorCode.NormalizationDiverged, + error.Code, + "The quotation has no normal form that the normalizer can reach." + ) + + Assert.Contains ( + "nested too deeply", + error.Message, + StringComparison.Ordinal, + "The message should say that the quotation is nested too deeply." + ) + + [] + member _.``A quotation without a normal form must be reported when it grows deeper with every rewriting step`` () = + // As above, but every step leaves the next application inside a negation, so the quotation grows deeper and + // deeper: the normalizer has to stop before the stack of the thread is used up. + let error = + NormalizerAssert.WantError + <@ + let self = + fun (loop : Loop) -> + match loop with + | Loop apply -> not (apply loop) + + self (Loop self) + @> + + Assert.AreEqual(TranslationErrorCode.NormalizationDiverged, error.Code, "The rewriting has no end.") diff --git a/tests/Cosmos.Quotations.Tests/NormalizerSpellingTests.fs b/tests/Cosmos.Quotations.Tests/NormalizerSpellingTests.fs new file mode 100644 index 00000000..0e951ca5 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/NormalizerSpellingTests.fs @@ -0,0 +1,567 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System.Collections.Generic +open System.Collections.Immutable +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations + +/// +/// One way to write a function, next to the plain way to write the same function: with operators and members of the +/// document only. The normalizer has to make one quotation of both. +/// +type Spelling = { + /// What is special about the way the function is written; the name of a test result starts with it. + Name : string + /// The quotation of the function as it is written. + Written : Expr + /// The quotation of the plain way to write it. + Plain : Expr + /// Fails unless the function that a quotation holds computes what the compiled code of the written function does. + ComputesTheSame : Expr -> unit +} with + + /// + /// The spelling of the function that writes plainly, to be + /// evaluated on . + /// + static member Over<'Input, 'Result when 'Result : equality> + ( + name : string, + inputs : 'Input seq, + [] written : Expr<'Input -> 'Result>, + plain : Expr<'Input -> 'Result> + ) + : Spelling + = + let written = Quoted.Split written + + { + Name = name + Written = written.Quotation + Plain = plain + ComputesTheSame = NormalizerAssert.ComputesTheSame written.Compiled inputs + } + + /// + /// The spelling of the function of a person that writes plainly. + /// + static member Of<'Result when 'Result : equality> + (name : string, [] written : Expr 'Result>, plain : Expr 'Result>) + : Spelling + = + let written = Quoted.Split written + + { + Name = name + Written = written.Quotation + Plain = plain + ComputesTheSame = NormalizerAssert.ComputesTheSame written.Compiled Persons.all + } + + /// + /// The spelling of the function of a person that writes plainly, + /// for a way of writing that only a quotation literal has, such as a splice: the compiler cannot give the code of + /// such a quotation, so is the same function as code. + /// + static member OfQuotation<'Result when 'Result : equality> + (name : string, written : Expr 'Result>, compiled : Person -> 'Result, plain : Expr 'Result>) + : Spelling + = { + Name = name + Written = written + Plain = plain + ComputesTheSame = NormalizerAssert.ComputesTheSame compiled Persons.all + } + +/// +/// The normal form of a function does not depend on how the function is written: every +/// has the normal form of its plain way, the normal form +/// stays what it is when it is normalized again, and it computes what the compiled code computes. +/// +[] +type NormalizerSpellingTests () = + + static let spellings = + // Captured by the quotations below: a local value arrives in a quotation as a named value, which is how a + // parameter of a query is written. + let limit = 30 + let invoices = [| Invoice ("a", 50); Invoice ("", 150) |] + let nicks = [| None; Some "x"; Some "y" |] + + // Spliced into the quotations below. Every splice of one quotation is the same nodes, variables included. + let isAdult = <@ fun (person : Person) -> person.Age >= 18 @> + + let hasTagThat = + <@ fun (predicate : string -> bool) (person : Person) -> person.Tags |> List.exists (fun tag -> predicate tag) @> + + seq { + // Pipes + Spelling.Of ( + "a forward pipe into a function written in place", + (fun p -> p.Age |> fun age -> age > 18), + <@ fun p -> p.Age > 18 @> + ) + Spelling.Of ( + "a forward pipe into a function", + (fun p -> p |> Conditions.isTeenager), + <@ fun p -> Conditions.isTeenager p @> + ) + Spelling.Of ( + "a forward pipe into a partly applied function", + (fun p -> p.Tags |> List.contains "vip"), + <@ fun p -> List.contains "vip" p.Tags @> + ) + Spelling.Of ( + "a chain of forward pipes", + (fun p -> + p.Tags + |> List.filter (fun tag -> tag <> "") + |> List.isEmpty + |> not + ), + <@ fun p -> not (List.isEmpty (List.filter (fun tag -> tag <> "") p.Tags)) @> + ) + Spelling.Of ("a backward pipe", (fun p -> not <| (p.Age > 18)), <@ fun p -> not (p.Age > 18) @>) + Spelling.Of ("a forward pipe of two values", (fun p -> (p.Age, 18) ||> (>)), <@ fun p -> p.Age > 18 @>) + Spelling.Of ( + "a forward pipe of three values", + (fun p -> + (p.Age, 18, 65) + |||> (fun age low high -> age >= low && age <= high) + ), + <@ fun p -> p.Age >= 18 && p.Age <= 65 @> + ) + Spelling.Of ("a backward pipe of two values", (fun p -> (>) <|| (p.Age, 18)), <@ fun p -> p.Age > 18 @>) + Spelling.Of ( + "a backward pipe of three values", + (fun p -> + (fun age low high -> age >= low && age <= high) + <||| (p.Age, 18, 65) + ), + <@ fun p -> p.Age >= 18 && p.Age <= 65 @> + ) + Spelling.Of ( + "a pipe of two values that are one tuple of the document", + (fun p -> p.Scores ||> (>)), + <@ + fun p -> + let (best, worst) = p.Scores + best > worst + @> + ) + + // Spliced quotations + Spelling.OfQuotation ( + "a quotation that is spliced in and applied", + <@ fun p -> (%isAdult) p && p.Active @>, + (fun p -> p.Age >= 18 && p.Active), + <@ fun p -> p.Age >= 18 && p.Active @> + ) + Spelling.OfQuotation ( + "an untyped quotation that is spliced in and applied", + <@ fun p -> (%%isAdult.Raw : Person -> bool) p @>, + (fun p -> p.Age >= 18), + <@ fun p -> p.Age >= 18 @> + ) + Spelling.OfQuotation ( + "a quotation that is spliced in twice", + <@ fun p -> (%isAdult) p || not ((%isAdult) p) @>, + (fun p -> p.Age >= 18 || not (p.Age >= 18)), + <@ fun p -> p.Age >= 18 || not (p.Age >= 18) @> + ) + Spelling.OfQuotation ( + "a quotation that is spliced into its own argument", + <@ fun p -> (%hasTagThat) (fun outer -> (%hasTagThat) (fun inner -> inner <> outer) p) p @>, + (fun p -> + p.Tags + |> List.exists (fun outer -> p.Tags |> List.exists (fun inner -> inner <> outer)) + ), + <@ fun p -> List.exists (fun outer -> List.exists (fun inner -> inner <> outer) p.Tags) p.Tags @> + ) + + // Functions that are not written as a function + Spelling.Of ("a function that is the whole function", Conditions.isAdult, <@ fun p -> p.Age >= 18 @>) + Spelling.Of ( + "a partly applied function that is the whole function", + Conditions.isOlderThan 18, + <@ fun p -> p.Age > 18 @> + ) + + // Composition + Spelling.Of ( + "a forward composition that is applied", + (fun p -> (Conditions.isAdult >> not) p), + <@ fun p -> not (p.Age >= 18) @> + ) + Spelling.Of ( + "a backward composition that is applied", + (fun p -> (not << Conditions.isAdult) p), + <@ fun p -> not (p.Age >= 18) @> + ) + Spelling.Of ("a composition that is the whole function", Conditions.isAdult >> not, <@ fun p -> not (p.Age >= 18) @>) + Spelling.Of ( + "a composition of three functions", + (fun (p : Person) -> p.Age) >> Conditions.twice >> ((<) 50), + <@ fun p -> 50 < p.Age + p.Age @> + ) + + // Bindings + Spelling.Of ( + "a value that is bound once and used twice", + (fun p -> + let age = p.Age + age > 18 && age < 65 + ), + <@ fun p -> p.Age > 18 && p.Age < 65 @> + ) + Spelling.Of ( + "a tuple pattern", + (fun p -> + let (low, high) = (18, 65) + p.Age >= low && p.Age <= high + ), + <@ fun p -> p.Age >= 18 && p.Age <= 65 @> + ) + Spelling.Of ( + "a struct tuple pattern", + (fun p -> + let struct (low, high) = struct (18, 65) + p.Age >= low && p.Age <= high + ), + <@ fun p -> p.Age >= 18 && p.Age <= 65 @> + ) + Spelling.Of ( + "a variable that hides another of the same name", + (fun p -> + let age = p.Age + let age = age + 1 + age > 18 + ), + <@ fun p -> p.Age + 1 > 18 @> + ) + Spelling.Of ( + "an operator that is applied to its first argument only", + (fun p -> p.Age |> (<) 18), + <@ fun p -> 18 < p.Age @> + ) + Spelling.Of ( + "a match on an option that is built in place", + (fun p -> + match Some p.Age with + | Some age -> age > 18 + | None -> false + ), + <@ fun p -> p.Age > 18 @> + ) + Spelling.Of ( + "a match on a value option that is built in place", + (fun p -> + match ValueSome p.Age with + | ValueSome age -> age > 18 + | ValueNone -> false + ), + <@ fun p -> p.Age > 18 @> + ) + Spelling.Over ( + "a match that binds the value of an option", + nicks, + (fun nick -> + match nick with + | Some value -> value = "x" + | None -> false + ), + <@ + fun nick -> + match nick with + | Some _ -> nick.Value = "x" + | None -> false + @> + ) + + // Functions and members with a reflected definition + Spelling.Of ("a function", (fun p -> Conditions.isAdult p), <@ fun p -> p.Age >= 18 @>) + Spelling.Of ( + "a curried function with a captured argument", + (fun p -> Conditions.isOlderThan limit p), + <@ fun p -> p.Age > limit @> + ) + Spelling.Of ( + "a function of a tuple and a person", + (fun p -> Conditions.isBetween (18, 65) p), + <@ fun p -> p.Age >= 18 && p.Age <= 65 @> + ) + Spelling.Of ("a function of one tuple", (fun p -> Conditions.isNamed ("Bob", p)), <@ fun p -> p.Name = "Bob" @>) + Spelling.Of ("a function of the unit value", (fun p -> p.Age >= Conditions.adultAge ()), <@ fun p -> p.Age >= 18 @>) + Spelling.Of ("a generic function", (fun p -> Conditions.hasValue p.Nick), <@ fun p -> p.Nick.IsSome @>) + Spelling.Of ( + "an inline function with an operator", + (fun p -> Conditions.twice p.Age > 50), + <@ fun p -> p.Age + p.Age > 50 @> + ) + Spelling.Of ("an inline method with an operator", (fun p -> p.IsOlderThanTwice 9), <@ fun p -> p.Age > 9 + 9 @>) + Spelling.Of ( + "an inline static method with an operator", + (fun p -> Person.Doubled p.Age > 50), + <@ fun p -> p.Age + p.Age > 50 @> + ) + Spelling.Of ( + "a function that calls other functions", + (fun p -> Conditions.isWorkingAge p), + <@ fun p -> p.Age >= 18 && not (p.Age > 64) @> + ) + Spelling.Of ( + "a function that takes a function", + (fun p -> p |> Conditions.hasTagThat (fun tag -> tag = "vip")), + <@ fun p -> List.exists (fun tag -> tag = "vip") p.Tags @> + ) + Spelling.Of ( + "a function that takes a function, inside its own argument", + (fun p -> + p + |> Conditions.hasTagThat (fun outer -> p |> Conditions.hasTagThat (fun inner -> inner <> outer)) + ), + <@ fun p -> List.exists (fun outer -> List.exists (fun inner -> inner <> outer) p.Tags) p.Tags @> + ) + Spelling.Of ( + "a function that takes a struct anonymous record", + (fun p -> + p + |> Conditions.isOlderThanMinimum (struct {| MinAge = 18 |}) + ), + <@ fun p -> p.Age > 18 @> + ) + Spelling.Of ( + "a function that matches on a union, called with the first case", + (fun p -> p |> Conditions.satisfies (ByName "Bob")), + <@ fun p -> p.Name = "Bob" @> + ) + Spelling.Of ( + "a function that matches on a union, called with the second case", + (fun p -> p |> Conditions.satisfies (OlderThan 18)), + <@ fun p -> p.Age > 18 @> + ) + Spelling.Of ("a method", (fun p -> p.IsOlderThan 18), <@ fun p -> p.Age > 18 @>) + Spelling.Of ("a method of two arguments", (fun p -> p.IsBetween (18, 65)), <@ fun p -> p.Age >= 18 && p.Age <= 65 @>) + Spelling.Of ("a curried method", (fun p -> p.IsWithin 18 65), <@ fun p -> p.Age >= 18 && p.Age <= 65 @>) + Spelling.Of ("a property", (fun p -> p.IsAdult), <@ fun p -> p.Age >= 18 @>) + Spelling.Of ("a static method", (fun p -> Person.IsNamed ("Bob", p)), <@ fun p -> p.Name = "Bob" @>) + Spelling.Of ("an extension method", (fun p -> p.IsYoungerThan 18), <@ fun p -> p.Age < 18 @>) + Spelling.Of ( + "an extension method of two arguments", + (fun p -> p.IsOutside (18, 65)), + <@ fun p -> p.Age < 18 || p.Age > 65 @> + ) + Spelling.Of ("an extension property", (fun p -> p.HasNick), <@ fun p -> p.Nick.IsSome @>) + Spelling.Of ("a static extension property", (fun p -> p.Age >= Person.AdultAge), <@ fun p -> p.Age >= 18 @>) + Spelling.Over ( + "a static property", + invoices, + (fun invoice -> invoice.Total > Invoice.LargeTotal), + <@ fun invoice -> invoice.Total > 100 @> + ) + Spelling.Over ( + "a method of a base class", + invoices, + (fun invoice -> invoice.HasId "a"), + <@ fun invoice -> (invoice :> DocumentBase).Id = "a" @> + ) + Spelling.Over ( + "a property of a base class", + invoices, + (fun invoice -> invoice.IsIdentified), + <@ fun invoice -> (invoice :> DocumentBase).Id <> "" @> + ) + + // Parts of values that are built in place + Spelling.Of ( + "the first item of a pair that is built in place", + (fun p -> fst (p.Age, p.Name) > 18), + <@ fun p -> p.Age > 18 @> + ) + Spelling.Of ( + "the second item of a pair that is built in place", + (fun p -> snd (p.Name, p.Age) > 18), + <@ fun p -> p.Age > 18 @> + ) + Spelling.Of ( + "the first item of a pair of the document", + (fun p -> fst p.Scores > 5), + <@ + fun p -> + let (best, _) = p.Scores + best > 5 + @> + ) + Spelling.Of ( + "the second item of a pair of the document", + (fun p -> snd p.Scores > 5), + <@ + fun p -> + let (_, worst) = p.Scores + worst > 5 + @> + ) + #nowarn "3220" // the item property of a tuple is what the case is about + Spelling.Of ("the item property of a pair", (fun p -> (p.Age, p.Name).Item1 > 18), <@ fun p -> p.Age > 18 @>) + #warnon "3220" + Spelling.Of ( + "a field of a record that is built in place", + (fun p -> p.Age > { Low = 18; High = 65 }.Low), + <@ fun p -> p.Age > 18 @> + ) + Spelling.Of ( + "a field of an anonymous record that is built in place", + (fun p -> {| Low = 18; High = p.Age |}.High > 18), + <@ fun p -> p.Age > 18 @> + ) + Spelling.Of ( + "a field of a struct anonymous record that is built in place", + (fun p -> (struct {| Low = 18; High = p.Age |}).High > 18), + <@ fun p -> p.Age > 18 @> + ) + + // Booleans + Spelling.Of ("a boolean that is compared with true", (fun p -> p.Active = true), <@ fun p -> p.Active @>) + Spelling.Of ("true that is compared with a boolean", (fun p -> true = p.Active), <@ fun p -> p.Active @>) + Spelling.Of ("a boolean that is compared with false", (fun p -> p.Active = false), <@ fun p -> not p.Active @>) + Spelling.Of ("a boolean that is not true", (fun p -> p.Active <> true), <@ fun p -> not p.Active @>) + Spelling.Of ("a boolean that is not false", (fun p -> p.Active <> false), <@ fun p -> p.Active @>) + Spelling.Of ("a double negation", (fun p -> not (not p.Active)), <@ fun p -> p.Active @>) + Spelling.Of ("a choice between true and false", (fun p -> if p.Active then true else false), <@ fun p -> p.Active @>) + Spelling.Of ( + "a choice between false and true", + (fun p -> if p.Active then false else true), + <@ fun p -> not p.Active @> + ) + Spelling.Of ("a conjunction with true", (fun p -> p.Active && true), <@ fun p -> p.Active @>) + Spelling.Of ("a conjunction of true", (fun p -> true && p.Active), <@ fun p -> p.Active @>) + Spelling.Of ("a disjunction with false", (fun p -> p.Active || false), <@ fun p -> p.Active @>) + Spelling.Of ("a disjunction of false", (fun p -> false || p.Active), <@ fun p -> p.Active @>) + Spelling.Of ( + "a condition that is a constant", + (fun p -> if true then p.Active else p.Age > 5), + <@ fun p -> p.Active @> + ) + Spelling.Of ("the negation of a constant", (fun p -> p.Active && not false), <@ fun p -> p.Active @>) + // A boolean that is made with its constructor is the default value of the type in a quotation: false + Spelling.Of ( + "a boolean that is compared with the default value of its type", + (fun p -> p.Active = bool ()), + <@ fun p -> not p.Active @> + ) + Spelling.Of ( + "a condition that is the default value of a boolean", + (fun p -> if bool () then p.Age > 5 else p.Active), + <@ fun p -> p.Active @> + ) + + // Code that never runs: it has no normal form here, and needs none + Spelling.Of ( + "a branch without a normal form that a constant condition does not choose", + (fun p -> if true then p.Active else Conditions.factorial p.Age > 0), + <@ fun p -> p.Active @> + ) + Spelling.Of ( + "a part without a normal form after a conjunction with the default value of a boolean", + (fun p -> p.Active || (bool () && Conditions.factorial p.Age > 0)), + <@ fun p -> p.Active @> + ) + Spelling.Of ( + "a part without a normal form after a conjunction with false", + (fun p -> p.Active || (false && Conditions.factorial p.Age > 0)), + <@ fun p -> p.Active @> + ) + Spelling.Of ( + "a branch without a normal form that a condition does not choose once it is normalized", + (fun p -> + if not (false && p.Active) then + p.Active + else + Conditions.factorial p.Age > 0 + ), + <@ fun p -> p.Active @> + ) + Spelling.Of ( + "a branch without a normal form that a constant bound before the condition does not choose", + (fun p -> + let onlyActive = true + if onlyActive then + p.Active + else + Conditions.factorial p.Age > 0 + ), + <@ fun p -> p.Active @> + ) + Spelling.Of ( + "a branch without a normal form that a constant passed to a function in place does not choose", + (fun p -> + (fun onlyActive -> + if onlyActive then + p.Active + else + Conditions.factorial p.Age > 0 + ) + true + ), + <@ fun p -> p.Active @> + ) + Spelling.Of ( + "a branch without a normal form that a piped constant does not choose", + (fun p -> + true + |> fun onlyActive -> + if onlyActive then + p.Active + else + Conditions.factorial p.Age > 0 + ), + <@ fun p -> p.Active @> + ) + Spelling.Of ( + "a branch without a normal form that a constant passed to a function with a definition does not choose", + (fun p -> Conditions.isActiveOrCounted true p), + <@ fun p -> p.Active @> + ) + } + |> ImmutableArray.CreateRange + + /// + /// Every spelling as a row of a data-driven test. The name of a row replaces the name of the test method in the + /// results, so it says what is special about the spelling and what the method asserts. + /// + static member private Rows (law : string) : IEnumerable> = + spellings + |> Seq.map (fun spelling -> TestDataRow(spelling, DisplayName = $"%s{spelling.Name} %s{law}")) + + /// The rows of the test that compares the normal forms of the two ways to write a function. + static member SameFormRows = + NormalizerSpellingTests.Rows "must have the normal form of the plain way to write the function" + + /// The rows of the test that normalizes a normal form again. + static member StableFormRows = + NormalizerSpellingTests.Rows "must have a normal form that normalization returns as it is" + + /// The rows of the test that compares the normal form with the compiled code. + static member SameMeaningRows = + NormalizerSpellingTests.Rows "must have a normal form that computes what the compiled code computes" + + [] + member _.``A spelling must have the normal form of the plain way to write the function`` (spelling : Spelling) = + NormalizerAssert.AreEquivalent + (NormalizerAssert.WantNormal spelling.Plain) + (NormalizerAssert.WantNormal spelling.Written) + "Both ways to write the function should have one normal form." + + [] + member _.``A spelling must have a normal form that normalization returns as it is`` (spelling : Spelling) = + let normal = NormalizerAssert.WantNormal spelling.Written + + Assert.AreSame( + normal, + NormalizerAssert.WantNormal normal, + "A quotation in normal form should be returned as the same node." + ) + + [] + member _.``A spelling must have a normal form that computes what the compiled code computes`` (spelling : Spelling) = + spelling.ComputesTheSame (NormalizerAssert.WantNormal spelling.Written) diff --git a/tests/Cosmos.Quotations.Tests/NormalizerTests.fs b/tests/Cosmos.Quotations.Tests/NormalizerTests.fs new file mode 100644 index 00000000..f1825cda --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/NormalizerTests.fs @@ -0,0 +1,435 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations +open FSharp.Quotations.DerivedPatterns +open FSharp.Quotations.Patterns + +open Swensen.Unquote + +/// +/// What the normalizer leaves in a quotation and what it must not touch: the facts that a pair of spellings in +/// cannot state. +/// +[] +type NormalizerTests () = + + /// Whether a quotation reads the property of a value that has this name. + static let reads (name : string) (expr : Expr) : bool = + match expr with + | PropertyGet (Some _, property, []) -> String.Equals (property.Name, name, StringComparison.Ordinal) + | _ -> false + + /// Whether a quotation is a sum. + static let isSum (expr : Expr) : bool = + match expr with + | SpecificCall <@@ (+) @@> _ -> true + | _ -> false + + [] + member _.``A quotation in normal form must be returned as the same node`` () = + let quotation = <@ fun (p : Person) -> p.Active && p.Name = "Bob" @> + + Assert.AreSame(quotation, NormalizerAssert.WantNormal quotation, "Nothing in the quotation is to be rewritten.") + + [] + member _.``A captured boolean must stay in a comparison because it is a parameter and not a constant`` () = + let enabled = true + let quotation = <@ fun (p : Person) -> p.Active = enabled @> + + Assert.AreSame( + quotation, + NormalizerAssert.WantNormal quotation, + "The comparison with a captured value should stay: the text of a query must not depend on the value." + ) + + [] + member _.``A module-level value with a reflected definition must stay a reference to the value`` () = + let quotation = <@ fun (p : Person) -> p.Age >= Conditions.retirementAge @> + + Assert.AreSame( + quotation, + NormalizerAssert.WantNormal quotation, + "A module-level value is computed once, so its definition should not be written into the quotation." + ) + + [] + member _.``A module-level value that is a function of the unit value must stay a reference to the value`` () = + let quotation = <@ fun (p : Person) -> p.Age >= Conditions.earlyRetirementAge () @> + + Assert.AreSame( + quotation, + NormalizerAssert.WantNormal quotation, + "The definition of the value has the type of a getter that takes the unit value, and is no getter." + ) + + [] + member _.``A call of a function without a reflected definition must stay a call`` () = + let quotation = <@ fun (p : Person) -> Conditions.isTeenager p && p.IsRetired () @> + + Assert.AreSame( + quotation, + NormalizerAssert.WantNormal quotation, + "A function whose definition cannot be read should stay a call." + ) + + [] + member _.``A call of a member that a derived class can override must stay a call`` () = + let quotation = <@ fun (document : DocumentBase) -> document.Describe () = "invoice a" @> + + let describe = + match quotation with + | Lambda (_, Call (_, _, [ Call (_, method, _); _ ])) -> method + | _ -> invalidOp $"The quotation should compare the result of a call: %A{quotation}" + + Assert.IsTrue ( + (Expr.TryGetReflectedDefinition describe).IsSome, + "The member should have a reflected definition, or the test checks nothing." + ) + + Assert.AreSame( + quotation, + NormalizerAssert.WantNormal quotation, + "The definition in the base class says nothing about a derived class that overrides the member." + ) + + [] + member _.``A call that passes witnesses must become a plain call of the same operator`` () = + let quotation = <@ fun (p : Person) -> p.Age + 1 > 18 @> + + let passesWitnesses (expr : Expr) = + match expr with + | CallWithWitnesses _ -> true + | _ -> false + + Assert.IsTrue ( + Quotation.exists passesWitnesses quotation, + "The compiler should pass a witness to the addition, or the test checks nothing." + ) + + let normal = NormalizerAssert.WantNormal quotation + + Assert.IsFalse (Quotation.exists passesWitnesses normal, "No call should pass witnesses after normalization.") + normal + |> NormalizerAssert.ComputesTheSame (fun (p : Person) -> p.Age + 1 > 18) Persons.all + + [] + member _.``A struct anonymous record parameter must be read without its address`` () = + let condition = + Quoted.Of (fun (limits : struct {| MinAge : int |}) (p : Person) -> p.Age > limits.MinAge) + + let takesAddress (expr : Expr) = + match expr with + | AddressOf _ -> true + | _ -> false + + Assert.IsTrue ( + Quotation.exists takesAddress condition.Quotation, + "The compiler should read the struct record through its address, or the test checks nothing." + ) + + let normal = NormalizerAssert.WantNormal condition.Quotation + let limits = struct {| MinAge = 18 |} + + Assert.IsFalse (Quotation.exists takesAddress normal, "No address should be left after normalization.") + + Expr.Application (normal, Expr.Value limits) + |> NormalizerAssert.ComputesTheSame (condition.Compiled limits) Persons.all + + [] + member _.``The copy of a struct that the compiler binds must be gone`` () = + let condition = Quoted.Of (fun (date : DateTime) -> date.AddDays(1.0).Year > 2000) + + let binds (expr : Expr) = + match expr with + | Let _ -> true + | _ -> false + + Assert.IsTrue ( + Quotation.exists binds condition.Quotation, + "The compiler should bind a copy of the date, or the test checks nothing." + ) + + let normal = NormalizerAssert.WantNormal condition.Quotation + + Assert.IsFalse (Quotation.exists binds normal, "No binding should be left after normalization.") + + normal + |> NormalizerAssert.ComputesTheSame condition.Compiled [| DateTime (1999, 12, 31); DateTime (2000, 12, 31) |] + + [] + member _.``The mutable copy of a struct that the compiler binds must be gone when nothing assigns to it`` () = + let condition = + Quoted.Of (fun (invoice : Invoice) -> invoice.Note.IsSome && invoice.Note.Value = "paid") + + let bindsMutable (expr : Expr) = + match expr with + | Let (variable, _, _) -> variable.IsMutable + | _ -> false + + Assert.IsTrue ( + Quotation.exists bindsMutable condition.Quotation, + "The compiler should bind the note to a mutable variable, or the test checks nothing." + ) + + let normal = NormalizerAssert.WantNormal condition.Quotation + + Assert.IsFalse (Quotation.exists bindsMutable normal, "No binding should be left after normalization.") + + normal + |> NormalizerAssert.ComputesTheSame condition.Compiled [| + Invoice ("a", 50) + Invoice ("b", 50, Note = ValueSome "paid") + Invoice ("c", 50, Note = ValueSome "open") + |] + + [] + member _.``A bound value that is used twice must be the same node at both places`` () = + let quotation = + <@ + fun (p : Person) -> + let year = DateTime.UtcNow.Year + p.Age < year && p.Age + 1900 < year + @> + + NormalizerAssert.WantNormal quotation + |> NormalizerAssert.IsOneNode + 2 + (reads "Year") + "Both places should hold the node that was bound, so that a later stage can tell they are one value." + + [] + member _.``A value that a function binds must be one node in a call and another node in another call`` () = + let quotation = + <@ + fun (p : Person) -> + Conditions.isWithinProcessors p + || not (Conditions.isWithinProcessors p) + @> + + NormalizerAssert.WantNormal quotation + |> NormalizerAssert.AreNodes + 2 + 4 + (fun expr -> + match expr with + | PropertyGet (None, property, []) -> String.Equals (property.Name, "ProcessorCount", StringComparison.Ordinal) + | _ -> false + ) + "A call computes the number once for its two places, and the other call computes it for itself." + + [] + member _.``An argument that a function uses twice must be the same node at both places`` () = + let quotation = + <@ fun (p : Person) -> (fun year -> p.Age < year && p.Age + 1900 < year) DateTime.UtcNow.Year @> + + NormalizerAssert.WantNormal quotation + |> NormalizerAssert.IsOneNode 2 (reads "Year") "The code computes an argument once, however often the function uses it." + + [] + member _.``Values bound one after another must each be the same node at all their places`` () = + let quotation = + <@ + fun (p : Person) -> + let year = DateTime.UtcNow.Year + let month = DateTime.UtcNow.Month + (p.Age < year && p.Age > month) + || (fst p.Scores < year && fst p.Scores > month) + @> + + let normal = NormalizerAssert.WantNormal quotation + + normal + |> NormalizerAssert.IsOneNode 2 (reads "Year") "Writing the month into the quotation should leave the year one node." + + normal + |> NormalizerAssert.IsOneNode 2 (reads "Month") "Writing the year into the quotation should leave the month one node." + + [] + member _.``A bound value that reads another bound value must stay one node`` () = + let quotation = + <@ + fun (p : Person) -> + let year = DateTime.UtcNow.Year + let next = year + 1 + p.Age < next && fst p.Scores < next + @> + + NormalizerAssert.WantNormal quotation + |> NormalizerAssert.IsOneNode + 2 + isSum + "The sum is bound once, so writing the year into it should give one sum for both places and not one for each." + + [] + member _.``A bound value must stay one node when a later rewrite changes it`` () = + // Writing the pair into the sum leaves the reading of an item of a pair that is built in place, which is + // rewritten to that item afterwards, at both places of the sum. + let quotation = + <@ + fun (p : Person) -> + let pair = (p.Age, fst p.Scores) + let sum = fst pair + snd pair + sum > 1 && sum < 100 + @> + + NormalizerAssert.WantNormal quotation + |> NormalizerAssert.IsOneNode 2 isSum "The sum is bound once, so both places should get the same rewritten sum." + + [] + member _.``A bound function that is passed twice must stay one node`` () = + let quotation = + <@ + fun (p : Person) -> + let name = Environment.MachineName + let isIt = fun (tag : string) -> tag = name + List.exists isIt p.Tags || List.forall isIt p.Tags + @> + + let isFunctionOfTag (expr : Expr) = + match expr with + | Lambda (parameter, _) -> Type.(=) (parameter.Type, typeof) + | _ -> false + + NormalizerAssert.WantNormal quotation + |> NormalizerAssert.IsOneNode + 2 + isFunctionOfTag + "Writing the name into the function should give one function for both places, with one reading of the name." + + [] + member _.``A quotation that is spliced into two places must stay one node when it is rewritten`` () = + // The spliced quotation is not in normal form: it binds a value. + let year = + <@ + let now = DateTime.UtcNow + now.Year + @> + + let quotation = <@ fun (p : Person) -> p.Age < %year && p.Age + 1900 < %year @> + + NormalizerAssert.WantNormal quotation + |> NormalizerAssert.IsOneNode + 2 + (reads "Year") + "A splice puts the node it is given at both places, and both should get the one normal form of that node." + + [] + member _.``A quotation that is spliced into two places must stay one node when a value is written around it`` () = + let year = <@ DateTime.UtcNow.Year @> + + let quotation = + <@ + fun (p : Person) -> + let century = 1900 + p.Age < %year && p.Age + century < %year + @> + + NormalizerAssert.WantNormal quotation + |> NormalizerAssert.IsOneNode + 2 + (reads "Year") + "Writing the bound number into the quotation should leave the spliced node one node." + + [] + member _.``A variable that an inner function binds again must not be replaced inside that function`` () = + // One variable that two functions bind, one inside the other: a quotation that is spliced into itself arrives + // this way, because every splice of it is the same nodes. + // (fun number -> List.exists (fun number -> number > 6) [ 1 ] || number > 9) 7 + let number = Var ("number", typeof) + let isLarge = Expr.Lambda (number, <@@ %%(Expr.Var number) > 6 @@>) + let body = + <@@ + List.exists (%%isLarge : int -> bool) [ 1 ] + || %%(Expr.Var number) > 9 + @@> + let normal = NormalizerAssert.WantNormal (Expr.Application (Expr.Lambda (number, body), <@@ 7 @@>)) + + Assert.IsFalse ( + evalRaw normal, + "The inner function tests its own argument, 1, and not the 7 that the outer function was applied to." + ) + + [] + member _.``A function parameter must be renamed when a value with the same variable is moved under it`` () = + // The argument is the variable that the inner function binds too, so writing it into the inner function as it + // is would make it the inner parameter. + // fun number -> (fun first -> fun number -> first - number) number + let number = Var ("number", typeof) + let first = Var ("first", typeof) + let subtract = + Expr.Lambda (first, Expr.Lambda (number, <@@ %%(Expr.Var first) - %%(Expr.Var number) @@>)) + let normal = + NormalizerAssert.WantNormal (Expr.Lambda (number, Expr.Application (subtract, Expr.Var number))) + + Assert.AreEqual( + 7, + evalRaw int -> int> normal 10 3, + "The first argument should stay the outer parameter: 10 - 3, not 3 - 3." + ) + + [] + member _.``A delegate parameter must be renamed when a value with the same variable is moved under it`` () = + // The same with a delegate as the inner function. A quotation keeps the parameters of a delegate in a function + // under the node of the delegate, so they are bindings like any other. + // fun number -> (fun first -> Func (fun number -> first - number)) number + let number = Var ("number", typeof) + let first = Var ("first", typeof) + let subtract = + Expr.Lambda ( + first, + Expr.NewDelegate (typeof>, [ number ], <@@ %%(Expr.Var first) - %%(Expr.Var number) @@>) + ) + + match NormalizerAssert.WantNormal (Expr.Lambda (number, Expr.Application (subtract, Expr.Var number))) with + | Lambda (outer, NewDelegate (_, [ inner ], Call (None, _, [ Var minuend; Var subtrahend ]))) -> + Assert.AreNotSame(outer, inner, "The parameter of the delegate should be a variable of its own.") + Assert.AreSame(outer, minuend, "The first argument should stay the outer parameter.") + Assert.AreSame(inner, subtrahend, "The second argument should stay the parameter of the delegate.") + | normal -> Assert.Fail $"The normal form should be a function that gives a delegate, but is %A{normal}." + + [] + member _.``A call of an inline method without its witnesses must stay a call`` () = + // The compiler passes an inline method its operators as witnesses, and the definition of the method takes them + // first. A call that is built through the API passes none, so the definition does not take its arguments. + let method = + match <@ fun (p : Person) -> p.IsOlderThanTwice 9 @> with + | Lambda (_, Call (Some _, method, _)) -> method + | other -> invalidOp $"The quotation should be a call of the method: %A{other}" + + let person = Var ("p", typeof) + let quotation = Expr.Lambda (person, Expr.Call (Expr.Var person, method, [ Expr.Value 9 ])) + + Assert.AreSame( + quotation, + NormalizerAssert.WantNormal quotation, + "A definition is applied only to the arguments it takes, so this call should be left as it is and nothing raised." + ) + + [] + member _.``A quotation that carries its compiled value must be normalized as the quotation`` () = + let condition = Quoted.Of (fun (p : Person) -> p |> Conditions.isAdult) + let carried = Expr.WithValue (condition.Compiled, typeof bool>, condition.Quotation) + + NormalizerAssert.AreEquivalent + <@ fun (p : Person) -> p.Age >= 18 @> + (NormalizerAssert.WantNormal carried) + "The compiled value should be dropped and the quotation normalized." + + [] + member _.``A composition must keep the parameter name of its first function`` () = + let quotation = + <@ + (fun (person : Person) -> person.Age) + >> (fun age -> age > 18) + @> + + match NormalizerAssert.WantNormal quotation with + | Lambda (parameter, _) -> + Assert.AreEqual( + "person", + parameter.Name, + "The name the user chose should survive, because it becomes the alias in the query." + ) + | normal -> Assert.Fail $"The normal form of a composition should be a function, but is %A{normal}." diff --git a/tests/Cosmos.Quotations.Tests/QuotationAssert.fs b/tests/Cosmos.Quotations.Tests/QuotationAssert.fs new file mode 100644 index 00000000..b8a348bf --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/QuotationAssert.fs @@ -0,0 +1,177 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Concurrent +open System.Collections.Generic +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations +open FSharp.Quotations.ExprShape +open FSharp.Quotations.Patterns + +open Swensen.Unquote + +open FSharp.Azure.Cosmos.Quotations + +/// Questions about a quotation that the assertions and the tests ask. +[] +module Quotation = + + /// + /// The variables that stand for the bound variables of every quotation, by nesting depth and type. They are shared, + /// so that two quotations made canonical hold the very same variables. + /// + let private canonicalVariables = ConcurrentDictionary() + + /// + /// Creates the variable for a nesting depth and a type; a delegate that is created once, for + /// . + /// + let private createCanonicalVariable = + Func(fun (struct (depth, variableType)) -> Var ($"v%d{depth}", variableType)) + + /// + /// with the variables of replaced, and every variable bound + /// inside it replaced by the canonical variable of its depth, counted from . An inner + /// binding of a variable hides an outer one of the same variable. + /// + let rec private rename (replacements : Map) (depth : int) (expr : Expr) : Expr = + match expr with + | ShapeVar variable -> + match replacements |> Map.tryFind variable with + | Some replacement -> Expr.Var replacement + | None -> expr + | ShapeLambda (variable, body) -> + let replacement = canonicalVariables.GetOrAdd (struct (depth, variable.Type), createCanonicalVariable) + Expr.Lambda ( + replacement, + body + |> rename (replacements |> Map.add variable replacement) (depth + 1) + ) + | ShapeCombination (shape, parts) -> RebuildShapeCombination (shape, parts |> List.map (rename replacements depth)) + + /// + /// with every bound variable replaced by the variable that stands for its nesting depth and + /// type. Two quotations that differ only in their bound variables become equal: a quotation compares its variables + /// by identity, and every quotation literal creates variables of its own. + /// + let canonical (expr : Expr) : Expr = expr |> rename Map.empty 0 + + /// + /// Whether and are the same quotation up to their bound + /// variables. + /// + let areEquivalent (first : Expr) (second : Expr) : bool = (canonical first).Equals(canonical second) + + /// + /// The parts of , itself included, that satisfy , outermost + /// first. + /// + let rec filter (predicate : Expr -> bool) (expr : Expr) : Expr list = [ + if predicate expr then + expr + + match expr with + | ShapeVar _ -> () + | ShapeLambda (_, body) -> yield! filter predicate body + | ShapeCombination (_, parts) -> + for part in parts do + yield! filter predicate part + ] + + /// + /// Whether or a part of it satisfies . + /// + let exists (predicate : Expr -> bool) (expr : Expr) : bool = not (filter predicate expr).IsEmpty + +/// +/// A function as compiled code together with the quotation of the same code. +/// +type Quoted = + + /// + /// The two parts of , which a parameter marked with + /// that asks for the value received: the compiled + /// code and its quotation. + /// + static member Split (code : Expr<'Function>) : struct {| Compiled : 'Function; Quotation : Expr<'Function> |} = + match code with + | WithValue (compiled, _, quotation) -> struct {| + Compiled = compiled :?> 'Function + Quotation = Expr.Cast<'Function> quotation + |} + | _ -> invalidArg (nameof code) $"The compiler did not pass the compiled value with the quotation: %A{code}" + + /// + /// as compiled code and as a quotation. The compiler passes both for an argument that is + /// marked with and asks for the value, so a test + /// writes a function once and can compare what its quotation means with what the code does. + /// + static member Of + ([] code : Expr<'Function>) + : struct {| Compiled : 'Function; Quotation : Expr<'Function> |} + = + Quoted.Split code + +/// Assertions on what the normalizer makes of a quotation. +[] +module NormalizerAssert = + + /// + /// The normal form of ; fails when the normalizer reports an error. + /// + let WantNormal (expr : Expr) : Expr = + match Normalizer.normalize expr with + | Ok normal -> normal + | Error error -> + raise ( + AssertFailedException + $"The quotation should have a normal form, but: %s{error.Message}\n%s{error.Fragment}\n%A{expr}" + ) + + /// + /// The error the normalizer reports for ; fails when it gives a normal form. + /// + let WantError (expr : Expr) : TranslationError = + match Normalizer.normalize expr with + | Ok normal -> raise (AssertFailedException $"The quotation should be an error, but has the normal form\n%A{normal}") + | Error error -> error + + /// + /// Asserts that and are the same quotation up to their bound + /// variables. + /// + let AreEquivalent (expected : Expr) (actual : Expr) (message : string) : unit = + if not (Quotation.areEquivalent expected actual) then + raise (AssertFailedException $"%s{message}\nExpected:\n%A{expected}\nActual:\n%A{actual}") + + /// + /// Asserts that the parts of that satisfy stand at + /// places and are different nodes. + /// + let AreNodes (nodes : int) (places : int) (predicate : Expr -> bool) (message : string) (normal : Expr) : unit = + let found = Quotation.filter predicate normal + + Assert.HasCount (places, found, $"The part should stand at %d{places} places.\n%A{normal}") + let different = HashSet(Seq.cast found, ReferenceEqualityComparer.Instance) + Assert.HasCount (nodes, different, $"%s{message}\n%A{normal}") + + /// + /// Asserts that the parts of that satisfy are one and the + /// same node, which stands at places. + /// + let IsOneNode (places : int) (predicate : Expr -> bool) (message : string) (normal : Expr) : unit = + AreNodes 1 places predicate message normal + + /// + /// Asserts that the function computes, for every one of , + /// what computes. + /// + let ComputesTheSame (compiled : 'Input -> 'Result) (inputs : 'Input seq) (quotation : Expr) : unit = + let evaluated = evalRaw<'Input -> 'Result> quotation + + for input in inputs do + Assert.AreEqual<'Result>( + compiled input, + evaluated input, + $"The quotation should compute what the code computes for %A{input}.\n%A{quotation}" + ) diff --git a/tests/Cosmos.Quotations.Tests/TestCategories.fs b/tests/Cosmos.Quotations.Tests/TestCategories.fs new file mode 100644 index 00000000..c6ca9afa --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/TestCategories.fs @@ -0,0 +1,18 @@ +// The categories of the FSharp.Azure.Cosmos.Quotations tests. Every test here is a fast, emulator-free unit test, so +// every category also carries "Unit", which --filter TestCategory=Unit selects. The attributes are sorted by name. +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System.Collections.Generic +open Microsoft.VisualStudio.TestTools.UnitTesting + +/// +/// Categorizes a unit test of the normalizer: +/// , +/// and +/// . +/// +type NormalizerUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Normalizer" |] :> IList diff --git a/tests/Cosmos.Quotations.Tests/testconfig.json b/tests/Cosmos.Quotations.Tests/testconfig.json new file mode 100644 index 00000000..b43d5de5 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/testconfig.json @@ -0,0 +1,9 @@ +{ + "mstest": { + "parallelism": { + "enabled": true, + "scope": "method", + "workers": 0 + } + } +} \ No newline at end of file From a8d202dce9b3f1e234ef4021f3251ec7a3dee60f Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Mon, 12 Oct 2026 04:09:04 +0200 Subject: [PATCH 04/10] feat(quotations): compute the parts of a quotation that read no variable A query has parts that do not depend on the document, such as DateTime.UtcNow.AddDays -30.0 or limit + 1. Their values are known before the query runs and become its parameters. The evaluator computes such a value from a quotation in normal form. It works by reflection: properties and fields are read, methods and constructors called, tuples, records, unions and arrays built and taken apart, types and union cases tested, captured functions applied. Nothing is compiled, because turning a quotation into a delegate costs hundreds of microseconds. A choice computes only the branch its condition chooses, so a && b does not compute b when a is false. 37 operators of FSharp.Core refuse to be called by reflection: -, /, %, the unary and bitwise operators, the shifts, the conversions between number types and their checked forms. Their methods raise NotSupportedException, "Dynamic invocation of op_Subtraction is not supported", while + and * can be called. For each of them LanguagePrimitives has a function for operands of any types, which the compiler passes to the operator as a hidden argument; the evaluator takes the pairs from there. The checked operators are paired by hand: the compiler passes them the unchecked functions, with which Checked.byte 300 would give 44 instead of raising. Those functions fail for an enumeration type, so they are called for the number type under it, and a result that is an enumeration value is made one again. That also covers int over an enumeration value, whose own method can be called for other types. What reflection finds out about a type or a method is kept for the process: the precomputed constructors and readers of FSharp.Reflection take a record from 8 microseconds to 0.3 and an item of a tuple from 3 to 0.3. An exception of the code that is run becomes a TranslationError with the new code ClientEvaluationFailed and the exception itself in the new field Cause, taken out of the TargetInvocationException of reflection. A receiver that is null raises NullReferenceException, as compiled code does, and so does a function that is null when it is applied. Compiled code finds the null after it has computed the arguments, so an argument that raises comes first here as well. A member of a nullable is computed by a function that takes the nullable. Reflection has nothing to call such a member on: a nullable is boxed as its value or as null, never as itself, so HasValue of a nullable without a value would raise where it has to give false. The default value of a struct is its zeroed value, for which no constructor runs: a struct of another language can declare a constructor without parameters, and what that constructor makes is another value. A nullable without a value is null as an object. A coercion is a cast: a value that is not of the target type raises InvalidCastException, as the cast does in compiled code, and is not passed on as a value of a type it does not have. The compiler writes only coercions that cannot fail; a quotation that is built through the API can hold one that does. A node is computed once. The normalizer writes a value that a let bound at every place it is used, as the very same node, and the code computes a bound value once: let made = obj () in (made, made) is a pair of one object. So the evaluator keeps the values of the nodes it has computed, by their identity: for one part in tryEvaluate, and in tryEvaluateOnce for all the parts of one quotation, whose caller keeps them. That costs a part about 0.1 microseconds. Co-Authored-By: Claude Opus 5.5 --- .github/copilot-instructions.md | 3 +- src/Cosmos.Quotations/Evaluator.fs | 623 ++++++++++++++++++ .../FSharp.Azure.Cosmos.Quotations.fsproj | 1 + src/Cosmos.Quotations/TranslationError.fs | 22 + 4 files changed, 648 insertions(+), 1 deletion(-) create mode 100644 src/Cosmos.Quotations/Evaluator.fs diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index da701b94..4d756b50 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -14,7 +14,8 @@ / ├── src/Cosmos.Quotations/ – translator of F# quotations into queries (FSharp.Azure.Cosmos.Quotations), built stage by stage and not packed yet │ ├── TranslationError.fs – translation errors and the place of a quotation in the source -│ └── Normalizer.fs – normal form of a quotation +│ ├── Normalizer.fs – normal form of a quotation +│ └── Evaluator.fs – value of a part of a quotation that reads no variable ├── src/Cosmos/ – main library (FSharp.Azure.Cosmos) │ ├── SubStatusCodes.fs – documented Cosmos DB sub-status codes │ ├── Cosmos.fs – core types and container extensions diff --git a/src/Cosmos.Quotations/Evaluator.fs b/src/Cosmos.Quotations/Evaluator.fs new file mode 100644 index 00000000..1608929f --- /dev/null +++ b/src/Cosmos.Quotations/Evaluator.fs @@ -0,0 +1,623 @@ +/// +/// Computes the value of a part of a quotation that reads no variable. Such a part does not depend on the document, so +/// its value is known before the query runs and becomes a parameter of the query. +/// +/// +/// +/// The part has to be in the normal form that +/// gives: +/// bindings, pipes and calls of functions with reflected definitions are gone. What is left to compute is done by +/// reflection: reading properties and fields, calling methods and constructors, building and reading tuples, records, +/// unions and arrays, testing a type or a union case, choosing between two branches and applying a captured function. +/// +/// +/// An operator of FSharp.Core that refuses to be called by reflection, such as -, / and the conversions +/// between number types, is computed by the function that FSharp.Core has for operands of any types. +/// +/// +/// Nothing is compiled. Turning a quotation into a delegate costs hundreds of microseconds, a thousand times what +/// reflection costs for a property chain, so a part that holds a function written in the quotation has no value +/// here. +/// +/// +/// A choice computes only the branch that its condition chooses, as compiled code does. && and +/// || are choices, so text.IsSome && text.Value.Length > 0 over a captured option without a +/// value is and raises nothing. +/// +/// +/// A node is computed once. The normalizer writes a value that a bound at every place it is +/// used, as the very same node, and the code computes a bound value once: let made = obj () in (made, made) is +/// a pair of one object, here as in compiled code. +/// +/// +/// One node at two places is one value whatever put it there: one quotation that is spliced into two places, or a +/// tree that is built through the API with one node twice, is computed once as well, where compiled code would run it +/// at each place. For code without side effects the two cannot differ. +/// +/// +module internal FSharp.Azure.Cosmos.Quotations.Evaluator + +open System +open System.Collections.Concurrent +open System.Collections.Frozen +open System.Collections.Generic +open System.Collections.Immutable +open System.Reflection +open System.Runtime.CompilerServices +open FSharp.Quotations +open FSharp.Quotations.DerivedPatterns +open FSharp.Quotations.Patterns +open FSharp.Reflection + +/// A part that has no value without compiling it or without a variable: a function, a variable, a quotation. +exception private NotComputable of part : Expr + +/// The members of a type whatever their accessibility: a record or union of the caller may be internal or private. +[] +let private AnyAccessibility = BindingFlags.Public ||| BindingFlags.NonPublic + +// The reflection functions of FSharp.Core declare the values they take as not null. Null is a value they handle all +// the same: it is what a tuple, a record or a union case holds for a reference that is null, and how a union such as +// option represents its case without fields. These two functions are the one place that says so. +#nowarn "3261" + +/// +/// as the reflection functions of FSharp.Core take them. +/// +let private asValues (values : objnull array) : obj array = values + +/// +/// as the reflection functions of FSharp.Core take it. +/// +let private asValue (value : objnull) : obj = value + +#warnon "3261" + +/// +/// as a function that computes its result once for every key and keeps it for the process. +/// What is kept here is what reflection finds out about a type or a method, which takes microseconds to find and never +/// changes. +/// +let private memoize<'Key, 'Value when 'Key : not null> (create : 'Key -> 'Value) : 'Key -> 'Value = + let results = ConcurrentDictionary<'Key, 'Value>() + // The delegate is created once: a new one for every lookup would be an allocation for every lookup. + let factory = Func<'Key, 'Value> create + fun key -> results.GetOrAdd (key, factory) + +/// The function that builds a tuple of a type from its items. +let private tupleConstructorOf = + memoize (fun (tupleType : Type) -> FSharpValue.PreComputeTupleConstructor tupleType) + +/// The function that takes a tuple of a type apart into its items, also the items beyond the seventh. +let private tupleReaderOf = + memoize (fun (tupleType : Type) -> FSharpValue.PreComputeTupleReader tupleType) + +/// The function that builds a record of a type, also of an anonymous record type, from the values of its fields. +let private recordConstructorOf = + memoize (fun (recordType : Type) -> FSharpValue.PreComputeRecordConstructor (recordType, AnyAccessibility)) + +/// The function that builds a value of a union case from the values of its fields. +let private unionConstructorOf = + memoize (fun (case : UnionCaseInfo) -> FSharpValue.PreComputeUnionConstructor (case, AnyAccessibility)) + +/// The function that reads the tag of a value of a union type. +let private tagReaderOf = + memoize (fun (unionType : Type) -> FSharpValue.PreComputeUnionTagReader (unionType, AnyAccessibility)) + +/// +/// The method that applies a function value of a type to one argument: +/// of that type. +/// +let private invokerOf = + memoize (fun (functionType : Type) -> + functionType.GetMethod ("Invoke", [| FSharpType.GetFunctionElements functionType |> fst |]) + |> nonNull + ) + +/// +/// The generic definition of the method that calls. +/// +let private calledDefinition (call : Expr) : MethodInfo = + match call with + | Call (_, method, _) -> method.GetGenericMethodDefinition () + | _ -> invalidArg (nameof call) $"The quotation is not a call: %A{call}" + +/// +/// An operator of FSharp.Core that refuses to be called by reflection, with the function that stands in for it: +/// the one that the compiler passes to , a call of the operator on integers, as the +/// witness of the operator. Both as generic definitions. +/// +let private operatorWithWitness (template : Expr) : struct (MethodInfo * MethodInfo) = + match template with + | CallWithWitnesses (None, operator, _, [ Lambdas (_, Call (None, witness, _)) ], _) -> + struct (operator.GetGenericMethodDefinition (), witness.GetGenericMethodDefinition ()) + | _ -> invalidArg (nameof template) $"The quotation is not a call of an operator with one witness: %A{template}" + +// FS1204 says that these two functions are for dynamic invocation and not for direct use. Dynamic invocation is what +// they are taken for: the quotations only name them and are never run. +#nowarn "1204" + +/// +/// The function of FSharp.Core that negates a value of any type and raises +/// when the result does not fit. +/// +let private checkedNegation = + calledDefinition <@ LanguagePrimitives.CheckedUnaryNegationDynamic 1 @> + +/// +/// The function of FSharp.Core that converts a value of any type to another type and raises +/// when the value does not fit. +/// +let private checkedConversion = + calledDefinition <@ LanguagePrimitives.CheckedExplicitDynamic 1 @> + +#warnon "1204" + +/// +/// The operators of FSharp.Core that refuse to be called by reflection, by the metadata token of the method, each with +/// the function of FSharp.Core that computes it for operands whose types are known only at run time. +/// +/// +/// +/// These operators are compiled into the code that uses them, and their own methods raise +/// , "Dynamic invocation of op_Subtraction is not supported". For every one +/// of them has a function that does the same for any types: +/// for the built-in number types directly, and for another type through the operator that the type defines. The +/// compiler passes that function to the operator as its witness, which is where the pairs are taken from. +/// +/// +/// The checked operators are paired by hand, because the compiler passes them the unchecked functions: a checked +/// conversion that does not fit must raise, as it does in compiled code. +/// +/// +/// +, *, the comparisons and the mathematical functions are not here: reflection can call them. +/// int is here although it can be called, because its own method fails for an enumeration value. +/// +/// +let dynamicOperators : FrozenDictionary = + seq { + yield! + seq { + <@@ 1 - 1 @@> + <@@ 1 / 1 @@> + <@@ 1 % 1 @@> + <@@ -(1) @@> + <@@ +(1) @@> + <@@ ~~~1 @@> + <@@ 1 &&& 1 @@> + <@@ 1 ||| 1 @@> + <@@ 1 ^^^ 1 @@> + <@@ 1 <<< 1 @@> + <@@ 1 >>> 1 @@> + <@@ byte 1 @@> + <@@ sbyte 1 @@> + <@@ int16 1 @@> + <@@ uint16 1 @@> + <@@ int 1L @@> + <@@ int32 1L @@> + <@@ uint32 1 @@> + <@@ int64 1 @@> + <@@ uint64 1 @@> + <@@ nativeint 1 @@> + <@@ unativeint 1 @@> + <@@ float 1 @@> + <@@ float32 1 @@> + <@@ decimal 1 @@> + <@@ char 1 @@> + } + |> Seq.map operatorWithWitness + + yield struct (calledDefinition <@@ Checked.(~-) 1 @@>, checkedNegation) + + yield! + seq { + <@@ Checked.byte 1 @@> + <@@ Checked.sbyte 1 @@> + <@@ Checked.int16 1 @@> + <@@ Checked.uint16 1 @@> + <@@ Checked.int 1L @@> + <@@ Checked.int32 1L @@> + <@@ Checked.uint32 1 @@> + <@@ Checked.int64 1 @@> + <@@ Checked.uint64 1 @@> + <@@ Checked.nativeint 1 @@> + <@@ Checked.unativeint 1 @@> + <@@ Checked.char 1 @@> + } + |> Seq.map (fun template -> struct (calledDefinition template, checkedConversion)) + } + |> _.ToFrozenDictionary((fun (struct (operator, _)) -> operator.MetadataToken), (fun (struct (_, dynamic)) -> dynamic)) + +/// The module of FSharp.Core, in which the metadata tokens of its operators are unique. +let private coreModule = typeof.Module + +/// +/// The function that stands in for a call of one of the +/// with its type arguments. +/// +[] +type private DynamicCall = { + /// The function of FSharp.Core, made for the types of the operands and of the result. + Function : MethodInfo + /// + /// The enumeration type of the result, when the operator gives one. The functions of FSharp.Core fail for an + /// enumeration type, so they are made for the underlying number type; reflection passes them an enumeration value + /// as its number, and a number that comes back becomes a value of this type again. + /// + ResultEnumeration : Type voption +} + +/// +/// , or the number type under it when it is an enumeration type. +/// +let private numberTypeOf (valueType : Type) : Type = + if valueType.IsEnum then + Enum.GetUnderlyingType valueType + else + valueType + +/// +/// The members of as functions that take the nullable. +/// +/// +/// Reflection has nothing to call a member of a nullable on: a nullable is boxed as its value or, when it has none, as +/// , never as itself. As an argument it can be passed, because there is +/// taken for the nullable without a value. +/// +[] +type private NullableMembers<'Value when 'Value : struct and 'Value : (new : unit -> 'Value) and 'Value :> ValueType> = + + /// + /// of . + /// + static member HasValue (nullable : Nullable<'Value>) : bool = nullable.HasValue + + /// + /// of . + /// + static member Value (nullable : Nullable<'Value>) : 'Value = nullable.Value + + /// + /// of . + /// + static member GetValueOrDefault (nullable : Nullable<'Value>) : 'Value = nullable.GetValueOrDefault () + + /// + /// of . + /// + static member GetValueOrDefault (nullable : Nullable<'Value>, defaultValue : 'Value) : 'Value = + nullable.GetValueOrDefault defaultValue + + /// + /// of . + /// + static member Equals (nullable : Nullable<'Value>, other : objnull) : bool = nullable.Equals other + + /// + /// of . + /// + static member GetHashCode (nullable : Nullable<'Value>) : int = nullable.GetHashCode () + + /// + /// of . + /// + static member ToString (nullable : Nullable<'Value>) : string | null = nullable.ToString () + +/// +/// Whether is a member of . +/// +let private isOfNullable (memberOfType : MemberInfo) : bool = + match memberOfType.DeclaringType with + | null -> false + | declaringType -> + // Nearly every member is one of a class, which the first test tells. + declaringType.IsValueType + && declaringType.IsGenericType + && Type.(=) (declaringType.GetGenericTypeDefinition (), typedefof>) + +/// +/// The function that stands in for a method of , also for the getter of a property: +/// the function of the same name that takes the nullable before the arguments of the method. +/// +let private nullableStandInOf = + memoize (fun (method : MethodInfo) -> + let nullableType = nonNull method.DeclaringType + // The getter of a property has the name of the property after "get_". + let name = + if method.IsSpecialName then + method.Name.Substring 4 + else + method.Name + + let parameterTypes = [| + nullableType + for parameter in method.GetParameters () do + parameter.ParameterType + |] + + typedefof> + .MakeGenericType(nullableType.GetGenericArguments ()) + .GetMethod( + name, + BindingFlags.Static + ||| BindingFlags.DeclaredOnly + ||| AnyAccessibility, + parameterTypes + ) + |> nonNull + ) + +/// +/// The function that stands in for a call of a method with its type arguments, when the method is one of the +/// ; no value for a method that is called +/// itself. The type arguments of the function are the types of the operands and then the type of the result, as many +/// as the function takes. +/// +let private dynamicCallOf = + memoize (fun (method : MethodInfo) -> + if method.Module.Equals coreModule then + match dynamicOperators.TryGetValue method.MetadataToken with + | true, dynamic -> + let types = [| + for parameter in method.GetParameters () do + numberTypeOf parameter.ParameterType + numberTypeOf method.ReturnType + |] + + ValueSome { + Function = dynamic.MakeGenericMethod (types |> Array.take (dynamic.GetGenericArguments().Length)) + ResultEnumeration = + if method.ReturnType.IsEnum then + ValueSome method.ReturnType + else + ValueNone + } + | _ -> ValueNone + else + ValueNone + ) + +/// +/// as a value of , as a cast gives it: the value itself when it +/// is of that type, and the exception of a failed cast when it is not. +/// +/// +/// The compiler writes a coercion only where the cast cannot fail, for :> and for an argument that is passed +/// as a base type. A quotation that is built through the API can hold one that fails, and without this check its +/// value would be of another type than the part it is the value of. A cast converts nothing: a boxed integer is no +/// byte, in compiled code either. +/// +let private castTo (targetType : Type) (value : objnull) : objnull = + match value with + | null -> + // Null is a value of every reference type and of a nullable; unboxing it as any other value type fails. + match targetType.IsValueType, Nullable.GetUnderlyingType targetType with + | true, null -> raise (NullReferenceException ()) + | _ -> null + | value when targetType.IsInstanceOfType value -> value + | value -> + raise ( + InvalidCastException + $"Unable to cast object of type '%s{value.GetType().FullName}' to type '%s{targetType.FullName}'." + ) + +/// +/// The values of the nodes of quotations that have been computed, by the identity of the node. The normalizer writes a +/// value that a bound at every place it is used, as the very same node; with the values kept +/// here such a node is computed at the first place that needs its value and never again, as the code computes a +/// bound value once. +/// +/// +/// One of these serves one part, or all the parts of one quotation for a caller that computes several of them: see +/// . +/// +[] +type Computed () = + + // By identity, because a quotation compares and hashes itself by walking all of itself. Made when the first value + // is kept: a part that is a captured value keeps none. + let mutable values : Dictionary | null = null + + /// + /// The value of , when it has been computed. + /// + member _.TryFind (node : Expr) : objnull voption = + match values with + | null -> ValueNone + | values -> + match values.TryGetValue node with + | true, value -> ValueSome value + | _ -> ValueNone + + /// + /// Remembers that has . + /// + member _.Add (node : Expr, value : objnull) : unit = + match values with + | null -> + let created = Dictionary ReferenceEqualityComparer.Instance + created.Add (node, value) + values <- created + | values -> values.Add (node, value) + +/// +/// , the value that a member is called on or that is applied as a function. When it is null, +/// this raises what compiled code raises for it, and not what reflection raises for a call on nothing. +/// +/// +/// Compiled code computes the arguments of a call before it finds that the receiver is null, so this is asked after +/// the arguments are computed: when one of them raises, its exception is the one that the code raises. +/// +let private called (target : objnull) : obj = + match target with + | null -> raise (NullReferenceException ()) + | target -> target + +/// +/// as a member takes its receiver: the value for a member of a value, checked with +/// , and for a +/// static member. +/// +let private calledOn (receiver : Expr option) (target : objnull) : objnull = + match receiver with + | None -> null + | Some _ -> called target + +/// +/// The value of . Exceptions of the code it runs come out as they are raised, mostly wrapped +/// in a . +/// +/// +/// What has been computed so far: the value of a node that is in it is taken from it, and the value of every other +/// node that runs code is added to it. +/// +/// The part to compute. +let rec private valueOf (computed : Computed) (expr : Expr) : objnull = + match expr with + | Value (value, _) -> value + | _ -> + match computed.TryFind expr with + | ValueSome value -> value + | ValueNone -> + let value = computedValueOf computed expr + computed.Add (expr, value) + value + +/// +/// The value of a node that is no value written in the quotation: what its code gives now. +/// +and private computedValueOf (computed : Computed) (expr : Expr) : objnull = + match expr with + | PropertyGet (receiver, property, arguments) -> + match receiver with + | Some nullable when isOfNullable property -> nullableMember computed (nonNull property.GetMethod) nullable arguments + | _ -> + let target = receiverOf computed receiver + let values = valuesOf computed arguments + property.GetValue (calledOn receiver target, values) + | FieldGet (receiver, field) -> field.GetValue (calledOn receiver (receiverOf computed receiver)) + | Call (None, method, arguments) -> + match dynamicCallOf method with + | ValueSome dynamic -> + match dynamic.ResultEnumeration, dynamic.Function.Invoke (null, valuesOf computed arguments) with + | ValueSome enumeration, (NonNull number) -> Enum.ToObject (enumeration, number) + | _, result -> result + | ValueNone -> method.Invoke (null, valuesOf computed arguments) + | Call (receiver, method, arguments) -> + match receiver with + | Some nullable when isOfNullable method -> nullableMember computed method nullable arguments + | _ -> + let target = receiverOf computed receiver + let values = valuesOf computed arguments + method.Invoke (calledOn receiver target, values) + | IfThenElse (condition, whenTrue, whenFalse) -> + if valueOf computed condition :?> bool then + valueOf computed whenTrue + else + valueOf computed whenFalse + | NewObject (constructor, arguments) -> constructor.Invoke (valuesOf computed arguments) + | NewTuple items -> tupleConstructorOf expr.Type (asValues (valuesOf computed items)) + | NewRecord (recordType, items) -> recordConstructorOf recordType (asValues (valuesOf computed items)) + | NewUnionCase (case, items) -> unionConstructorOf case (asValues (valuesOf computed items)) + | NewArray (elementType, items) -> + let array = Array.CreateInstance (elementType, items.Length) + items + |> List.iteri (fun index item -> array.SetValue (valueOf computed item, index)) + array + | TupleGet (tuple, index) -> (tupleReaderOf tuple.Type (asValue (valueOf computed tuple)))[index] + | UnionCaseTest (union, case) -> tagReaderOf case.DeclaringType (asValue (valueOf computed union)) = case.Tag + | TypeTest (value, tested) -> tested.IsInstanceOfType (valueOf computed value) + | Coerce (value, targetType) -> castTo targetType (valueOf computed value) + | DefaultValue valueType -> + // The zeroed value of a struct, for which no constructor runs: a struct of another language can declare a + // constructor without parameters, and the default value is not what that constructor makes. A nullable + // without a value is null as an object, like the default value of a class. + match Nullable.GetUnderlyingType valueType with + | null when valueType.IsValueType -> RuntimeHelpers.GetUninitializedObject valueType + | _ -> null + | Application (func, argument) -> + let target = valueOf computed func + let value = valueOf computed argument + (invokerOf func.Type).Invoke(called target, [| value |]) + | _ -> raise (NotComputable expr) + +/// +/// The value of the receiver of a member, for a static member and for a receiver that is null. +/// +and private receiverOf (computed : Computed) (receiver : Expr option) : objnull = + match receiver with + | None -> null + | Some receiver -> valueOf computed receiver + +/// +/// The value of a member of a nullable. The nullable is passed to the function that stands in for the member, so a +/// nullable without a value is one, and not a receiver that is null. +/// +and private nullableMember (computed : Computed) (method : MethodInfo) (nullable : Expr) (arguments : Expr list) : objnull = + (nullableStandInOf method).Invoke(null, [| valueOf computed nullable; yield! valuesOf computed arguments |]) + +/// The values of the arguments of a member, in their order. +and private valuesOf (computed : Computed) (arguments : Expr list) : objnull array = + arguments |> List.map (valueOf computed) |> List.toArray + +/// +/// The error for a part that raised while it was computed. +/// +let private failed (part : Expr) (cause : exn) : TranslationError = + part + |> TranslationError.ofException + TranslationErrorCode.ClientEvaluationFailed + $"A part of the quotation that reads nothing of the document has to be computed before the query runs, and computing it raised %s{cause.GetType().Name}: %s{cause.Message}" + (ImmutableArray.Create + "Compute the value before the quotation, where the exception can be handled, and use the result in the quotation.") + cause + +/// +/// The error for a part that has no value without compiling it. +/// +let private notComputable (part : Expr) : TranslationError = + part + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + "A part of the quotation that reads nothing of the document has to be computed before the query runs, but it holds a function, a variable or another quotation, which cannot be computed without compiling the quotation." + (ImmutableArray.Create "Compute the value before the quotation and use the result in the quotation.") + +/// +/// The value of or the error that says why it has none, with for +/// the nodes that were computed before. +/// +let private evaluate (computed : Computed) (expr : Expr) : Result = + try + Ok (valueOf computed expr) + with + | NotComputable part -> Error (notComputable part) + | :? TargetInvocationException as invocation -> + match invocation.InnerException with + | null -> Error (failed expr invocation) + | cause -> Error (failed expr cause) + | cause -> Error (failed expr cause) + +/// +/// The value of , a part of a quotation in normal form that reads no variable, or the error +/// that says why it has none. A node that stands at several places of the part is computed once. +/// +/// +/// +/// The code of the part raised an exception: +/// with the exception as +/// its . Any exception is taken, because the code +/// is the caller's and may raise any. +/// The part holds a function, a variable or another quotation: +/// . +/// +/// +let tryEvaluate (expr : Expr) : Result = evaluate (Computed ()) expr + +/// +/// for a +/// caller that computes several parts of one quotation: a node that was computed for an earlier part is not computed +/// again for this one. +/// +/// What has been computed so far; what is computed now is added. +/// A part of a quotation in normal form that reads no variable. +let tryEvaluateOnce (computed : Computed) (expr : Expr) : Result = evaluate computed expr diff --git a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj index acda5228..1406bd69 100644 --- a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj +++ b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj @@ -23,6 +23,7 @@ + diff --git a/src/Cosmos.Quotations/TranslationError.fs b/src/Cosmos.Quotations/TranslationError.fs index 897746ab..5455ab9c 100644 --- a/src/Cosmos.Quotations/TranslationError.fs +++ b/src/Cosmos.Quotations/TranslationError.fs @@ -46,6 +46,12 @@ type TranslationErrorCode = /// finish within its limit of steps. /// | NormalizationDiverged + /// + /// A part of the quotation that reads nothing of the document has to be computed before the query runs, and + /// computing it failed: the code in it raised an exception, which is the + /// . + /// + | ClientEvaluationFailed /// /// Why a quotation cannot be translated into a query, with the part of the quotation that is the reason. @@ -70,6 +76,8 @@ type TranslationError = { Location : SourceRange voption /// What to write instead, in English; empty when there is no general advice. Hints : ImmutableArray + /// The exception that code of the quotation raised, when that is the reason. + Cause : exn voption } /// @@ -140,8 +148,21 @@ module internal TranslationError = Fragment = string fragment Location = SourceRange.tryOfQuotation fragment Hints = hints + Cause = ValueNone } + /// + /// The error with , and about + /// that the exception is the reason of. + /// + let ofException + (code : TranslationErrorCode) + (message : string) + (hints : ImmutableArray) + (cause : exn) + (fragment : Expr) + : TranslationError = { ofQuotation code message hints fragment with Cause = ValueSome cause } + /// /// The error with and about a quotation as a whole: it names no /// part of it. @@ -152,4 +173,5 @@ module internal TranslationError = Fragment = "" Location = ValueNone Hints = ImmutableArray.Empty + Cause = ValueNone } From 805a54276ec47ebf692387e957f35e8e8dbfead9 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Mon, 12 Oct 2026 04:09:05 +0200 Subject: [PATCH 05/10] test(quotations): cover the evaluator Every case is code that reads no variable, passed to the test together with its quotation by the compiler, so the expected value is what the code gives when it runs. There is a case for every kind of node, for every operator that FSharp.Core does not let reflection call, for every member of a nullable with and without a value, and for enumeration values, whose computed value also has to be of the enumeration type and not the number under it. Code that raises is checked for the error it becomes: the code, the exception as the cause, its name in the message and the place in the source. A coercion that its value does not fit is built through the API and checked for the exception of the failed cast. The default value of a struct with a constructor without parameters, which F# does not declare, is checked on a type that the test makes at run time. A value that is bound once is checked to be computed once: at two places of one part, and in two parts for a caller that keeps what was computed. One test asks FSharp.Core which operators it marks as not callable and fails when one of them has no stand-in in the evaluator, so that a new version of FSharp.Core cannot add one unnoticed. Co-Authored-By: Claude Opus 5.5 --- .../Cosmos.Quotations.Tests/EvaluatorTests.fs | 615 ++++++++++++++++++ ...Sharp.Azure.Cosmos.Quotations.Tests.fsproj | 1 + tests/Cosmos.Quotations.Tests/Model.fs | 15 + .../Cosmos.Quotations.Tests/TestCategories.fs | 10 + 4 files changed, 641 insertions(+) create mode 100644 tests/Cosmos.Quotations.Tests/EvaluatorTests.fs diff --git a/tests/Cosmos.Quotations.Tests/EvaluatorTests.fs b/tests/Cosmos.Quotations.Tests/EvaluatorTests.fs new file mode 100644 index 00000000..54901a80 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/EvaluatorTests.fs @@ -0,0 +1,615 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open System.Globalization +open System.Reflection +open System.Reflection.Emit +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations +open FSharp.Quotations.Patterns + +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// +/// A value written as code that reads no variable of a quotation: the part of the quotation to compute, and what the +/// compiled code gives for it. +/// +type Computation = { + /// What kind of code computes the value; the name of a test result starts with it. + Name : string + /// The code in the normal form of the normalizer, without the function it was written in. + Part : Expr + /// Fails unless a value is what the compiled code gives. + IsExpected : objnull -> unit +} with + + /// + /// The part of a quotation that computes. The compiler passes the code together with its + /// quotation, so the expected value is what the code gives when it runs. + /// + static member Of<'Result when 'Result : equality> + (name : string, [] code : Expr 'Result>) + : Computation + = + let code = Quoted.Split code + + { + Name = name + Part = Computation.PartOf code.Quotation + IsExpected = + fun value -> + Assert.AreEqual<'Result>( + code.Compiled (), + (value :?> 'Result), + "The evaluator should compute what the compiled code computes." + ) + + // A boxed number can be taken out as an enumeration value, so the cast above does not tell them + // apart, but a parameter of a query is written by the type its value has. + match value with + | null -> () + | value when typeof<'Result>.IsEnum -> + Assert.AreEqual( + typeof<'Result>, + value.GetType (), + "A value of an enumeration type should be of that type, not the number under it." + ) + | _ -> () + } + + /// + /// The body of the function of the unit value that is, in normal form: a part that reads no + /// variable. + /// + static member PartOf (code : Expr) : Expr = + match NormalizerAssert.WantNormal code with + | Lambda (_, part) -> part + | normal -> invalidArg (nameof code) $"The code should be a function of the unit value: %A{normal}" + +/// +/// : the +/// value of a part of a quotation that reads no variable is what the compiled code of that part gives, and an exception +/// of that code is an error with the exception as its cause. +/// +[] +type EvaluatorTests () = + + static let computations = + // Captured by the code below, as a query captures the values it is asked with. + let limit = 30 + let price = 12.5 + let amount = 19.99m + let name = "Bob" + // A date is read as the field of a captured record: the compiler refuses to read a member of a captured local + // of a value type in a quotation (FS3155). + let meeting = {| At = DateTime (2024, 2, 29, 13, 30, 0, DateTimeKind.Utc) |} + let nick = Some "bobby" + let noNick : string option = None + let alias = ValueSome "bo" + let pair = (3, "three") + let structPair = struct (4, "four") + let eight = (1, 2, 3, 4, 5, 6, 7, "eight") + let range = { Low = 18; High = 65 } + let tags = [ "vip"; "new" ] + let filter = OlderThan 18 + let addOne = fun (number : int) -> number + 1 + let add = fun (first : int) (second : int) -> first + second + let wait = {| For = TimeSpan.FromMinutes 90.0 |} + // A nullable is read as the field of a captured record, like the date above. + let optional = {| Limit = Nullable 30; Missing = Nullable() |} + let flags = BindingFlags.Public ||| BindingFlags.Instance + + seq { + // Values and operators + Computation.Of ("a captured value", (fun () -> limit)) + Computation.Of ("a constant", (fun () -> 42)) + Computation.Of ("the sum of a captured value and a constant", (fun () -> limit + 1)) + Computation.Of ("arithmetic on integers", (fun () -> (limit - 4) * 3 / 2 % 7)) + Computation.Of ("the negation of a number", (fun () -> -limit)) + Computation.Of ("arithmetic on floating-point numbers", (fun () -> price * 2.0 + 0.5)) + Computation.Of ("arithmetic on decimals", (fun () -> amount * 2m + 0.01m)) + Computation.Of ("arithmetic on 64-bit integers", (fun () -> int64 limit * 4_000_000_000L)) + Computation.Of ("a conversion to a floating-point number", (fun () -> float limit / 4.0)) + Computation.Of ("a conversion to an integer", (fun () -> int price)) + Computation.Of ("a conversion to a string", (fun () -> string limit)) + Computation.Of ("the concatenation of strings", (fun () -> name + "!")) + Computation.Of ("a comparison", (fun () -> limit > 18)) + Computation.Of ("an equality of strings", (fun () -> name = "Bob")) + Computation.Of ("a negation", (fun () -> not (limit > 18))) + + // Operators that FSharp.Core does not let reflection call + Computation.Of ("a subtraction", (fun () -> limit - 4)) + Computation.Of ("a division", (fun () -> limit / 4)) + Computation.Of ("a remainder", (fun () -> limit % 4)) + Computation.Of ("a division of floating-point numbers", (fun () -> price / 4.0)) + Computation.Of ("a number with a plus sign", (fun () -> +limit)) + Computation.Of ("the complement of the bits of a number", (fun () -> ~~~limit)) + Computation.Of ("a bitwise and", (fun () -> limit &&& 12)) + Computation.Of ("a bitwise or", (fun () -> limit ||| 1)) + Computation.Of ("a bitwise exclusive or", (fun () -> limit ^^^ 5)) + Computation.Of ("a shift to the left", (fun () -> limit <<< 2)) + Computation.Of ("a shift to the right", (fun () -> limit >>> 2)) + Computation.Of ("a conversion to a byte", (fun () -> byte limit)) + Computation.Of ("a conversion to a signed byte", (fun () -> sbyte limit)) + Computation.Of ("a conversion to a 16-bit integer", (fun () -> int16 limit)) + Computation.Of ("a conversion to an unsigned 16-bit integer", (fun () -> uint16 limit)) + Computation.Of ("a conversion to a 32-bit integer", (fun () -> int32 price)) + Computation.Of ("a conversion to an unsigned 32-bit integer", (fun () -> uint32 limit)) + Computation.Of ("a conversion to a 64-bit integer", (fun () -> int64 price)) + Computation.Of ("a conversion to an unsigned 64-bit integer", (fun () -> uint64 limit)) + Computation.Of ("a conversion to a native integer", (fun () -> nativeint limit)) + Computation.Of ("a conversion to an unsigned native integer", (fun () -> unativeint limit)) + Computation.Of ("a conversion to a single-precision number", (fun () -> float32 limit)) + Computation.Of ("a conversion to a decimal", (fun () -> decimal limit)) + Computation.Of ("a conversion to a character", (fun () -> char (limit + 35))) + Computation.Of ("a conversion that cuts the value off", (fun () -> byte (limit * 10))) + Computation.Of ("a checked negation", (fun () -> Checked.(~-) limit)) + Computation.Of ("a checked conversion to a byte", (fun () -> Checked.byte limit)) + Computation.Of ("a checked conversion to a signed byte", (fun () -> Checked.sbyte limit)) + Computation.Of ("a checked conversion to a 16-bit integer", (fun () -> Checked.int16 limit)) + Computation.Of ("a checked conversion to an unsigned 16-bit integer", (fun () -> Checked.uint16 limit)) + Computation.Of ("a checked conversion to a 32-bit integer", (fun () -> Checked.int32 price)) + Computation.Of ("a checked conversion to an unsigned 32-bit integer", (fun () -> Checked.uint32 limit)) + Computation.Of ("a checked conversion to a 64-bit integer", (fun () -> Checked.int64 price)) + Computation.Of ("a checked conversion to an unsigned 64-bit integer", (fun () -> Checked.uint64 limit)) + Computation.Of ("a checked conversion to a native integer", (fun () -> Checked.nativeint limit)) + Computation.Of ("a checked conversion to an unsigned native integer", (fun () -> Checked.unativeint limit)) + Computation.Of ("a checked conversion to a character", (fun () -> Checked.char (limit + 35))) + Computation.Of ("a subtraction of decimals", (fun () -> amount - 0.99m)) + Computation.Of ("a division of a type with its own operator", (fun () -> wait.For / 2.0)) + Computation.Of ("the negation of a type with its own operator", (fun () -> -wait.For)) + Computation.Of ("the number of an enumeration value", (fun () -> int meeting.At.DayOfWeek)) + Computation.Of ("the 64-bit number of an enumeration value", (fun () -> int64 meeting.At.DayOfWeek)) + Computation.Of ("the checked number of an enumeration value", (fun () -> Checked.int meeting.At.DayOfWeek)) + Computation.Of ("the enumeration value of a number", (fun () -> enum(limit - 25))) + Computation.Of ("a combination of flags", (fun () -> BindingFlags.Public ||| BindingFlags.Static)) + Computation.Of ("the flags that two values share", (fun () -> flags &&& BindingFlags.Public)) + Computation.Of ("the complement of flags", (fun () -> ~~~flags)) + Computation.Of ("flags without one of them", (fun () -> flags &&& ~~~BindingFlags.Instance)) + + // Choices, which compute one branch only + Computation.Of ("a choice", (fun () -> if limit > 18 then "adult" else "minor")) + Computation.Of ( + "a conjunction whose second condition would fail", + (fun () -> noNick.IsSome && noNick.Value.Length > 0) + ) + Computation.Of ( + "a disjunction whose second condition would fail", + (fun () -> noNick.IsNone || noNick.Value.Length > 0) + ) + Computation.Of ("a conjunction of two conditions that hold", (fun () -> nick.IsSome && nick.Value.Length > 0)) + + // Members + Computation.Of ("a static field", (fun () -> DateTime.UnixEpoch)) + Computation.Of ("a static property", (fun () -> CultureInfo.InvariantCulture.Name)) + Computation.Of ("a module-level value", (fun () -> Conditions.retirementAge)) + Computation.Of ("a property of a string", (fun () -> name.Length)) + Computation.Of ("a chain of properties", (fun () -> meeting.At.Date.Year)) + Computation.Of ("a method with an argument", (fun () -> meeting.At.AddDays 2.0)) + Computation.Of ("a method of a string", (fun () -> name.ToUpperInvariant().Substring 1)) + Computation.Of ("a static method", (fun () -> Math.Max (limit, 18))) + Computation.Of ("a static method that parses", (fun () -> Guid.Parse "0d8f4b51-7d0d-4c35-9a53-4e0b3a1f6f10")) + Computation.Of ("a generic function", (fun () -> List.length tags)) + Computation.Of ("a function of a module", (fun () -> String.concat "," tags)) + Computation.Of ("a function without a reflected definition", (fun () -> Conditions.isTeenager Persons.child)) + Computation.Of ("a function with a reflected definition that calls itself", (fun () -> Conditions.factorial 5)) + Computation.Of ("a method of a captured record", (fun () -> Persons.retired.IsRetired ())) + Computation.Of ("an operator of a type", (fun () -> (meeting.At - DateTime.UnixEpoch).TotalDays)) + Computation.Of ("a member of an enumeration value", (fun () -> meeting.At.DayOfWeek = DayOfWeek.Thursday)) + + // Values that are built + Computation.Of ("a constructor", (fun () -> DateTime (2020, 1, 2))) + Computation.Of ("a nullable value", (fun () -> Nullable limit)) + Computation.Of ("a tuple", (fun () -> (limit, name))) + Computation.Of ("a struct tuple", (fun () -> struct (limit, name))) + Computation.Of ("a record", (fun () -> { Low = limit; High = 65 })) + Computation.Of ("an anonymous record", (fun () -> {| Name = name; Limit = limit |})) + Computation.Of ("a struct anonymous record", (fun () -> struct {| Name = name; Limit = limit |})) + Computation.Of ("a union case with a field", (fun () -> ByName name)) + Computation.Of ("an option with a value", (fun () -> Some limit)) + Computation.Of ("an option without a value", (fun () -> (None : int option))) + Computation.Of ("a value option with a value", (fun () -> ValueSome name)) + Computation.Of ("a list", (fun () -> [ limit; 1 ])) + Computation.Of ("a default value of a struct", (fun () -> Unchecked.defaultof)) + Computation.Of ("a default value of a class", (fun () -> Unchecked.defaultof)) + Computation.Of ("a struct that is made without arguments", (fun () -> DateTime ())) + Computation.Of ("a nullable without a value", (fun () -> Nullable())) + + // Values that are taken apart + Computation.Of ("the first item of a captured pair", (fun () -> fst pair)) + Computation.Of ("the second item of a captured pair", (fun () -> snd pair)) + Computation.Of ( + "an item of a captured struct tuple", + (fun () -> + let struct (number, _) = structPair + number + ) + ) + Computation.Of ( + "the eighth item of a captured tuple", + (fun () -> + let (_, _, _, _, _, _, _, last) = eight + last + ) + ) + Computation.Of ("a field of a captured record", (fun () -> range.High)) + Computation.Of ( + "a match on a captured option with a value", + (fun () -> + match nick with + | Some text -> text + | None -> "" + ) + ) + Computation.Of ( + "a match on a captured option without a value", + (fun () -> + match noNick with + | Some text -> text + | None -> "nobody" + ) + ) + Computation.Of ( + "a match on a captured value option", + (fun () -> + match alias with + | ValueSome text -> text + | ValueNone -> "" + ) + ) + Computation.Of ( + "a match on a captured union", + (fun () -> + match filter with + | ByName text -> text + | OlderThan age -> string age + ) + ) + Computation.Of ( + "a test of the type of a value", + (fun () -> + match box name with + | :? string as text -> text.Length + | _ -> -1 + ) + ) + Computation.Of ( + "a test of the type of a value of another type", + (fun () -> + match box limit with + | :? string as text -> text.Length + | _ -> -1 + ) + ) + Computation.Of ("a cast to an interface", (fun () -> (tags :> seq) |> Seq.length)) + + // Members of a nullable, which reflection has nothing to call on: a nullable is boxed as its value or as null + Computation.Of ("a nullable with a value that is asked whether it has one", (fun () -> optional.Limit.HasValue)) + Computation.Of ("a nullable without a value that is asked whether it has one", (fun () -> optional.Missing.HasValue)) + Computation.Of ("the value of a nullable", (fun () -> optional.Limit.Value)) + Computation.Of ("the value of a nullable or the default of its type", (fun () -> optional.Limit.GetValueOrDefault ())) + Computation.Of ( + "the default of its type for a nullable without a value", + (fun () -> optional.Missing.GetValueOrDefault ()) + ) + Computation.Of ("the value of a nullable or a default", (fun () -> optional.Limit.GetValueOrDefault 5)) + Computation.Of ("a default for a nullable without a value", (fun () -> optional.Missing.GetValueOrDefault 5)) + Computation.Of ("a nullable with a value as text", (fun () -> optional.Limit.ToString ())) + Computation.Of ("a nullable without a value as text", (fun () -> optional.Missing.ToString ())) + Computation.Of ("a nullable that is compared with a value", (fun () -> optional.Limit.Equals 30)) + Computation.Of ("a nullable without a value that is compared with null", (fun () -> optional.Missing.Equals null)) + Computation.Of ("the hash code of a nullable", (fun () -> optional.Limit.GetHashCode ())) + Computation.Of ("the hash code of a nullable without a value", (fun () -> optional.Missing.GetHashCode ())) + Computation.Of ("a nullable that is made of a value", (fun () -> Nullable limit)) + Computation.Of ("a nullable that a function takes", (fun () -> Option.ofNullable optional.Missing)) + + // Captured functions + Computation.Of ("a captured function that is applied", (fun () -> addOne limit)) + Computation.Of ("a captured function of two arguments", (fun () -> add limit 1)) + Computation.Of ("a captured function that is applied to what another gives", (fun () -> addOne (add limit 1))) + } + |> ImmutableArray.CreateRange + + static let failures = + let name = "Bob" + let limit = 30 + let noNick : string option = None + let refuse : unit -> int = fun () -> invalidOp "No value." + let optional = {| Missing = Nullable() |} + let missing : int -> int = Unchecked.defaultof int> + let noName : string = Unchecked.defaultof + + seq { + struct ("a text that is no number", Computation.PartOf <@ fun () -> Int32.Parse name @>, typeof) + struct ("a division by zero", Computation.PartOf <@ fun () -> limit / (limit - 30) @>, typeof) + struct ("a checked conversion that does not fit", + Computation.PartOf <@ fun () -> Checked.byte (limit * 10) @>, + typeof) + struct ("a checked negation that does not fit", + Computation.PartOf <@ fun () -> Checked.(~-) (Int32.MinValue + limit - 30) @>, + typeof) + struct ("a member of a value that is null", + Computation.PartOf <@ fun () -> noNick.Value.Length @>, + typeof) + struct ("a captured function that raises", + Computation.PartOf <@ fun () -> refuse () + 1 @>, + typeof) + struct ("the value of a nullable without a value", + Computation.PartOf <@ fun () -> optional.Missing.Value @>, + typeof) + struct ("a function that is null and is applied", + Computation.PartOf <@ fun () -> missing limit @>, + typeof) + // Compiled code computes the arguments before it finds that there is nothing to call. + struct ("a method of a value that is null with an argument that raises", + Computation.PartOf <@ fun () -> noName.Substring (limit / (limit - 30)) @>, + typeof) + struct ("an indexed property of a value that is null with an argument that raises", + Computation.PartOf <@ fun () -> noName.Chars (limit / (limit - 30)) @>, + typeof) + struct ("a function that is null and is applied to an argument that raises", + Computation.PartOf <@ fun () -> missing (limit / (limit - 30)) @>, + typeof) + } + |> ImmutableArray.CreateRange + + /// + /// Every computation as a row of a data-driven test. The name of a row replaces the name of the test method in the + /// results, so it says what is asserted. + /// + static member Computations : IEnumerable> = + computations + |> Seq.map (fun computation -> + TestDataRow( + computation, + DisplayName = $"%s{computation.Name} must have the value that the compiled code gives" + ) + ) + + /// + /// Every code that raises an exception, with the type of the exception, as a row of a data-driven test. + /// + static member Failures : IEnumerable> = + failures + |> Seq.map (fun (struct (name, part, cause)) -> + TestDataRow( + struct (part, cause), + DisplayName = $"%s{name} must be reported with the exception as the cause" + ) + ) + + [] + member _.``A part that reads no variable must have the value that the compiled code gives`` (computation : Computation) = + match Evaluator.tryEvaluate computation.Part with + | Ok value -> computation.IsExpected value + | Error error -> Assert.Fail $"The part should have a value, but: %s{error.Message}\n%s{error.Fragment}" + + [] + member _.``Code that raises an exception must be reported with the exception as the cause`` (part : Expr, cause : Type) = + let error = + Assert.WantError (Evaluator.tryEvaluate part, "The code raises an exception, so the part has no value.") + + Assert.AreEqual( + TranslationErrorCode.ClientEvaluationFailed, + error.Code, + "An exception of the caller's code is a failed evaluation." + ) + + let raised = Assert.WantValueSome (error.Cause, "The error should carry the exception.") + Assert.IsInstanceOfType (raised, cause, "The cause should be the exception of the code, not a wrapper of reflection.") + Assert.Contains (cause.Name, error.Message, StringComparison.Ordinal, "The message should name the exception.") + Assert.IsNotEmpty (error.Hints, "The error should say what to write instead.") + Assert.IsValueSome (error.Location, "The part was written in this file, so it has its place.") + + [] + member _.``Every operator that FSharp.Core does not let reflection call must have a function that stands in for it`` () = + // FSharp.Core marks the methods that raise when reflection calls them. Rethrow and Reraise are among them, and + // have nothing to compute. + let isMarked (method : MethodInfo) = + method.GetCustomAttributesData () + |> Seq.exists (fun attribute -> attribute.AttributeType.Name = "NoDynamicInvocationAttribute") + + let withoutStandIn = + seq { + typeof.Assembly.GetType("Microsoft.FSharp.Core.Operators", true) + typeof.Assembly.GetType("Microsoft.FSharp.Core.Operators+Checked", true) + } + |> Seq.collect (fun operators -> + match operators with + | null -> Seq.empty + | operators -> + operators.GetMethods (BindingFlags.Public ||| BindingFlags.Static) + |> Seq.ofArray + ) + |> Seq.filter (fun method -> + isMarked method + && not (method.Name.EndsWith ("$W", StringComparison.Ordinal)) + && method.Name <> "Rethrow" + && method.Name <> "Reraise" + && not (Evaluator.dynamicOperators.ContainsKey method.MetadataToken) + ) + |> Seq.map (fun method -> $"%s{(nonNull method.DeclaringType).Name}.%s{method.Name}") + |> Seq.toArray + + Assert.IsEmpty ( + withoutStandIn, + "A version of FSharp.Core that keeps another operator from reflection needs another row in the evaluator." + ) + + [] + member _.``A value that is bound once must be computed once for all its places in a part`` () = + let meter = Meter () + + let part = + Computation.PartOf + <@ + fun () -> + let made = meter.Read (obj ()) + obj.ReferenceEquals (made, made) + @> + + Assert.AreEqual( + true, + Assert.WantOk (Evaluator.tryEvaluate part, "A comparison of values that read no variable has a value."), + "Both places hold the node that was bound, so both should get the one object it makes, as in compiled code." + ) + + Assert.AreEqual(1, meter.Readings, "The code of the bound value should run once.") + + [] + member _.``A node that was computed must not be computed again for a caller that keeps what was computed`` () = + let meter = Meter () + + // Both parts hold the very same node: a splice puts the node it is given into the quotation. + let reading = <@ meter.Read 18 @> + let first = NormalizerAssert.WantNormal <@@ %reading + 1 @@> + let second = NormalizerAssert.WantNormal <@@ %reading + 2 @@> + let computed = Evaluator.Computed () + + Assert.AreEqual( + 19, + Assert.WantOk (Evaluator.tryEvaluateOnce computed first, "A sum of values that read no variable has a value."), + "The first part should be computed with the value of the node." + ) + + Assert.AreEqual( + 20, + Assert.WantOk (Evaluator.tryEvaluateOnce computed second, "A sum of values that read no variable has a value."), + "The second part should be computed with the value that the node had for the first one." + ) + + Assert.AreEqual(1, meter.Readings, "The code of the node should run once for both parts.") + + Assert.WantOk (Evaluator.tryEvaluate second, "A sum of values that read no variable has a value.") + |> ignore + + Assert.AreEqual(2, meter.Readings, "A caller that keeps nothing has the part computed anew.") + + [] + member _.``An array must be built with its items in their order`` () = + let limit = 30 + let part = Computation.PartOf <@ fun () -> [| limit; 1; limit + 1 |] @> + let value = + Assert.WantOk (Evaluator.tryEvaluate part, "An array of values that read no variable has a value.") + + match value with + | :? (int array) as items -> + CollectionAssert.AreEqual ( + [| 30; 1; 31 |], + items, + "The array should hold the three values in the order they are written." + ) + | other -> Assert.Fail $"The value should be an array of integers, but is %A{other}." + + [] + member _.``The default value of a struct must be its zeroed value when the struct has a constructor without parameters`` () = + // F# declares no struct with a constructor without parameters, as C# can, so the test makes one: its + // constructor sets the field to 7. + let declared = + AssemblyBuilder + .DefineDynamicAssembly(AssemblyName "EvaluatorTests.Dynamic", AssemblyBuilderAccess.Run) + .DefineDynamicModule("Structs") + .DefineType( + "Seven", + TypeAttributes.Public + ||| TypeAttributes.Sealed + ||| TypeAttributes.SequentialLayout, + typeof + ) + + let field = declared.DefineField ("Value", typeof, FieldAttributes.Public) + + let code = + declared.DefineConstructor(MethodAttributes.Public, CallingConventions.Standard, Type.EmptyTypes).GetILGenerator() + + code.Emit OpCodes.Ldarg_0 + code.Emit (OpCodes.Ldc_I4, 7) + code.Emit (OpCodes.Stfld, field) + code.Emit OpCodes.Ret + + let seven = declared.CreateType () + let valueOf (instance : objnull) = (nonNull (seven.GetField "Value")).GetValue instance + + Assert.AreEqual( + box 7, + valueOf (Activator.CreateInstance seven), + "The constructor of the struct sets the field, so a value that it made is told from the default value." + ) + + match Evaluator.tryEvaluate (Expr.DefaultValue seven) with + | Ok value -> + Assert.AreEqual( + box 0, + valueOf value, + "The default value is the zeroed value: no constructor runs for it, as none runs in compiled code." + ) + | Error error -> Assert.Fail $"The default value should be computed, but: %s{error.Message}" + + [] + member _.``A coercion must give the value only when the value is of the target type`` () = + // The compiler writes a coercion only where the cast cannot fail, so these are built through the API. + let coerced (value : Expr) (targetType : Type) = Evaluator.tryEvaluate (Expr.Coerce (value, targetType)) + + let causeOf (result : Result) = + let error = Assert.WantError (result, "A cast that fails in compiled code has no value.") + + Assert.AreEqual( + TranslationErrorCode.ClientEvaluationFailed, + error.Code, + "A failed cast is an exception of the code that is run." + ) + + Assert.WantValueSome (error.Cause, "The error should carry the exception.") + + Assert.AreEqual( + 5, + Assert.WantOk (coerced (Expr.Value 5) typeof>, "A number is a value of the nullable of its type."), + "The value should be the number." + ) + + Assert.IsNull ( + Assert.WantOk (coerced (Expr.Value (null, typeof)) typeof, "Null is a value of every reference type."), + "The value should stay null." + ) + + Assert.IsInstanceOfType ( + causeOf (coerced (Expr.Value (box "text", typeof)) typeof), + typeof, + "A text is no number, whatever type the coercion names." + ) + + Assert.IsInstanceOfType ( + causeOf (coerced (Expr.Value 5) typeof), + typeof, + "A cast converts nothing: a boxed integer is no byte." + ) + + Assert.IsInstanceOfType ( + causeOf (coerced (Expr.Value (null, typeof)) typeof), + typeof, + "Null is no value of a value type that is not a nullable." + ) + + [] + member _.``A function that is written in the quotation must be reported as having no value`` () = + let error = + Assert.WantError ( + Evaluator.tryEvaluate <@@ fun (number : int) -> number + 1 @@>, + "A function cannot be computed without compiling it." + ) + + Assert.AreEqual(TranslationErrorCode.Unsupported, error.Code, "Nothing was run, so nothing failed.") + Assert.IsValueNone (error.Cause, "No exception is the reason.") + + [] + member _.``A variable must be reported as having no value`` () = + let error = + Assert.WantError ( + Evaluator.tryEvaluate (Expr.Var (Var ("number", typeof))), + "A variable has a value only inside the query." + ) + + Assert.AreEqual(TranslationErrorCode.Unsupported, error.Code, "Nothing was run, so nothing failed.") diff --git a/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj b/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj index 1148efef..a7a238e8 100644 --- a/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj +++ b/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj @@ -32,6 +32,7 @@ + diff --git a/tests/Cosmos.Quotations.Tests/Model.fs b/tests/Cosmos.Quotations.Tests/Model.fs index 32480723..c6a3e01e 100644 --- a/tests/Cosmos.Quotations.Tests/Model.fs +++ b/tests/Cosmos.Quotations.Tests/Model.fs @@ -120,6 +120,21 @@ type Folder = { | Some parent -> parent.Depth + 1 | None -> 0 +/// A pass for values that counts them: a test tells by it how often a part of a quotation was computed. +type Meter () = + + let mutable readings = 0 + + /// How many values have passed. + member _.Readings = readings + + /// + /// , counted. + /// + member _.Read (value : 'Value) : 'Value = + readings <- readings + 1 + value + /// /// Members added to outside its definition: the compiler /// makes them static methods that take the person first. diff --git a/tests/Cosmos.Quotations.Tests/TestCategories.fs b/tests/Cosmos.Quotations.Tests/TestCategories.fs index c6ca9afa..62b6b86a 100644 --- a/tests/Cosmos.Quotations.Tests/TestCategories.fs +++ b/tests/Cosmos.Quotations.Tests/TestCategories.fs @@ -5,6 +5,16 @@ namespace FSharp.Azure.Cosmos.Quotations.Tests open System.Collections.Generic open Microsoft.VisualStudio.TestTools.UnitTesting +/// +/// Categorizes a unit test of the evaluator of the parts of a quotation that read no variable: +/// . +/// +type EvaluatorUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Evaluator" |] :> IList + /// /// Categorizes a unit test of the normalizer: /// , From 0165679d958136f08d8002f7017dcba956ce6852 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sun, 11 Oct 2026 22:17:28 +0200 Subject: [PATCH 06/10] feat(quotations): tell which parts of a quotation can be computed The stage that turns values into parameters has to choose the parts of a quotation to compute before it computes any of them: a part that turned out not to be computable half way would have run a half of its code for nothing. Evaluator.canEvaluate tells without running anything whether a part is made only of what the evaluator computes: it reads no variable and holds no function, delegate or quotation that is written in the quotation. That stage asks about a part and then about the parts under it. To refuse a part, the evaluator walks down to the reason, so it would look at the same parts once for every part above them. The parts it refused are remembered in a set that the caller keeps for all its questions. Co-Authored-By: Claude Opus 5.5 --- src/Cosmos.Quotations/Evaluator.fs | 70 ++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) diff --git a/src/Cosmos.Quotations/Evaluator.fs b/src/Cosmos.Quotations/Evaluator.fs index 1608929f..9814adb9 100644 --- a/src/Cosmos.Quotations/Evaluator.fs +++ b/src/Cosmos.Quotations/Evaluator.fs @@ -560,6 +560,76 @@ and private nullableMember (computed : Computed) (method : MethodInfo) (nullable and private valuesOf (computed : Computed) (arguments : Expr list) : objnull array = arguments |> List.map (valueOf computed) |> List.toArray +/// +/// The parts of quotations that +/// +/// has refused, by their identity. A caller that asks about a part and +/// then about the parts under it keeps one of these for all its questions: to refuse a part, every part on the way +/// down to the reason was looked at, and is not looked at again. +/// +[] +type Refused () = + + // By identity, because a quotation compares and hashes itself by walking all of itself. + let parts = HashSet ReferenceEqualityComparer.Instance + + /// + /// Whether has been refused. + /// + member _.Holds (part : Expr) : bool = parts.Contains part + + /// + /// Remembers that is refused. + /// + member _.Add (part : Expr) : unit = parts.Add part |> ignore + +/// +/// Whether is made only of what +/// +/// computes. Such a part reads no variable and holds no function that is written in the quotation, so it has a value +/// before the query runs, unless the code in it raises an exception. +/// +/// +/// The answer is given without running any code of the part: a caller asks it to choose the parts to compute, and a +/// part that turned out not to be computable half way would have run a half of its code for nothing. +/// +/// +/// The parts refused so far. A part that is refused now is added, with every part between it and the reason. +/// +/// The part of a quotation in normal form. +let rec canEvaluate (refused : Refused) (expr : Expr) : bool = + not (refused.Holds expr) + && (let can = + match expr with + | Var _ -> false + | Value _ + | DefaultValue _ -> true + | PropertyGet (receiver, _, arguments) + | Call (receiver, _, arguments) -> + receiver |> Option.forall (canEvaluate refused) + && arguments |> List.forall (canEvaluate refused) + | IfThenElse (condition, whenTrue, whenFalse) -> + canEvaluate refused condition + && canEvaluate refused whenTrue + && canEvaluate refused whenFalse + | FieldGet (receiver, _) -> receiver |> Option.forall (canEvaluate refused) + | NewObject (_, items) + | NewRecord (_, items) + | NewUnionCase (_, items) + | NewArray (_, items) + | NewTuple items -> items |> List.forall (canEvaluate refused) + | TupleGet (value, _) + | UnionCaseTest (value, _) + | TypeTest (value, _) + | Coerce (value, _) -> canEvaluate refused value + | Application (func, argument) -> canEvaluate refused func && canEvaluate refused argument + | _ -> false + + if not can then + refused.Add expr + + can) + /// /// The error for a part that raised while it was computed. /// From 0b34270ebc8995469577223c7f0e1e34c12c0935 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Mon, 12 Oct 2026 08:47:24 +0200 Subject: [PATCH 07/10] feat(quotations): tell the values of a quotation from its shape Two runs of one query differ only in the values the quotation was written with, so a query has to be translated once, and a later run only has to find that translation and supply the values. The parameterizer tells the two apart for a quotation in normal form: - the values that become parameters, each at a numbered place, a slot; - the key, ShapeKey: every node of the quotation without those values, in a form that can be compared and hashed. A quotation cannot be its own key: it compares its variables by identity, and every evaluation of a quotation literal creates new ones; - the template, for a query that has no translation yet: the quotation with a variable at the place of every slot. The rules: - a literal is a part of the key: a boolean, a character, a string, an integer or finite floating-point number, a value of an enumeration, unit and null. The ADR made literals parameters and wrote a value declared with Literal into the text, but the compiler writes such a value into a quotation exactly as it writes 18, so the two cannot be told apart. NaN and the infinities are no literals: a number in the text of a query is digits with a fraction and an exponent, so they are slots. A decimal is no literal here: the compiler writes 18m as a call that makes the decimal, so it is computed and is a slot, which keeps its digits. The type that a value is declared with decides, so a nullable is no literal, with a value or without one: a nullable with a value is boxed as that value, and the compiler writes neither as a value. The null of a union type is no literal either: it is the case of the union that is represented by null, as the None of an option is, and the compiler writes a case as a case. The default value of a type is the literal of that type when the type has one, as the zero of a number is, and data when it has none, as that of a date, a guid, a nullable or a union is, so it is a slot. The type tells, and no value is made to ask it: a struct can have a constructor without parameters, which a default value never runs; - a captured value is a slot named after its variable; - a part that reads nothing of the document, the largest one at its place, is computed by the evaluator and is a slot without a name; - a tuple, record, union case or array that the quotation builds stays what it is, because the translator has to see that Some limit is an option with a value and that a list is written item by item; - Query.constant and Query.parameter, two new public functions, say the opposite for their argument. A constant has to be a value that a literal can be: the key holds it, and equal keys have to mean one text, which the equality of an object does not promise. A slot stands for one node of the quotation. The compiler writes every use of a captured variable as a node of its own, so a variable that is used twice is two slots with one name. Nothing in those nodes says that they are one variable, because two spliced quotations can each have captured a variable of that name, and their values must not say it either: the key would depend on whether two values happen to be equal, and one query would have two texts. A value bound by let is written at every place it is used by the normalizer as the very same node, so it is one slot, and its code runs once, also when two different computed parts read it: the walk keeps what the evaluator computed for it. A choice whose condition is known before the query runs computes only the parts of the branch it takes, as compiled code does: in filter.IsNone || p.Name = filter.Value.Trim () nothing is trimmed without a filter. The parts of the other branch are slots without a value, and the key does not depend on which branch is taken. A condition under Query.constant decides its branch the same way. A function value that would have to be a parameter or a constant is reported as CapturedFunctionValue, also when it is passed as an object and the type of the part does not say what it is. A class made of the type of F# functions, which the class of every compiled function is and which code can declare, is a function by its type. The null and the default value of a function type, which only code can build into a quotation, are reported the same way: a literal by their looks, and no value that a query can use. An error about a part that has no place in the source of its own, as a captured value has none, gets the place of the nearest node around it. The template is built only when it is asked for: building a node of a quotation costs microseconds, and a quotation whose translation is known needs no node built. Co-Authored-By: Claude Opus 5.5 --- .github/copilot-instructions.md | 4 +- .../FSharp.Azure.Cosmos.Quotations.fsproj | 2 + src/Cosmos.Quotations/Parameterizer.fs | 977 ++++++++++++++++++ src/Cosmos.Quotations/Query.fs | 54 + src/Cosmos.Quotations/TranslationError.fs | 7 +- 5 files changed, 1040 insertions(+), 4 deletions(-) create mode 100644 src/Cosmos.Quotations/Parameterizer.fs create mode 100644 src/Cosmos.Quotations/Query.fs diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index 4d756b50..0f41e6f5 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -15,7 +15,9 @@ ├── src/Cosmos.Quotations/ – translator of F# quotations into queries (FSharp.Azure.Cosmos.Quotations), built stage by stage and not packed yet │ ├── TranslationError.fs – translation errors and the place of a quotation in the source │ ├── Normalizer.fs – normal form of a quotation -│ └── Evaluator.fs – value of a part of a quotation that reads no variable +│ ├── Evaluator.fs – value of a part of a quotation that reads no variable +│ ├── Query.fs – functions that say whether a value is a constant or a parameter of the query +│ └── Parameterizer.fs – shape of a quotation, by which its translation is found again, and the values of its parameters ├── src/Cosmos/ – main library (FSharp.Azure.Cosmos) │ ├── SubStatusCodes.fs – documented Cosmos DB sub-status codes │ ├── Cosmos.fs – core types and container extensions diff --git a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj index 1406bd69..c907c6c6 100644 --- a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj +++ b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj @@ -24,6 +24,8 @@ + + diff --git a/src/Cosmos.Quotations/Parameterizer.fs b/src/Cosmos.Quotations/Parameterizer.fs new file mode 100644 index 00000000..ed729aac --- /dev/null +++ b/src/Cosmos.Quotations/Parameterizer.fs @@ -0,0 +1,977 @@ +namespace FSharp.Azure.Cosmos.Quotations + +open System +open System.Collections.Immutable +open System.Reflection +open System.Text +open FSharp.Quotations +open FSharp.Quotations.ExprShape +open FSharp.Quotations.Patterns +open FSharp.Reflection + +/// +/// What a says about the node of a quotation it stands for. +/// +type internal ShapeTokenKind = + /// A variable that the quotation binds. The number says how many bindings lie between the variable and its own. + | Variable = 0 + /// A function written in the quotation. The subject is the type of its variable. + | Lambda = 1 + /// A delegate written in the quotation. The subject is the type of the delegate, the number counts its variables. + | NewDelegate = 2 + /// A value that is a part of the text of the query. The subject is its type, the detail the value. + | Constant = 3 + /// + /// A . The number is its index, the subject its type and the + /// detail the name of the captured variable, when it has one. + /// + | Slot = 4 + /// The value a type has before anything is assigned. The subject is the type. + | DefaultValue = 5 + /// A union case that is built. The subject is the case. + | NewUnionCase = 6 + /// A tuple that is built. The subject is the type of the tuple, which tells a struct tuple from a reference tuple. + | NewTuple = 7 + /// A record that is built. The subject is the type of the record. + | NewRecord = 8 + /// An array that is built. The subject is the type of its items, the number counts them. + | NewArray = 9 + /// A value seen as a value of another type. The subject is that type. + | Coerce = 10 + /// A choice between two branches. + | IfThenElse = 11 + /// A call of a method. The subject is the method, with its type arguments. + | Call = 12 + /// A reading of a property. The subject is the property. + | PropertyGet = 13 + /// A reading of a field. The subject is the field. + | FieldGet = 14 + /// A call of a constructor. The subject is the constructor. + | NewObject = 15 + /// A reading of an item of a tuple. The number is the index of the item. + | TupleGet = 16 + /// A test for a union case. The subject is the case. + | UnionCaseTest = 17 + /// A test for a type. The subject is the type. + | TypeTest = 18 + /// An application of a function value to an argument. + | Application = 19 + +/// +/// One node of a quotation, as a keeps it: the kind of the +/// node and what tells it from another node of that kind. The nodes under it follow it in the key. +/// +/// +/// Two tokens are equal when they say the same about a node. A member, a type and a union case are compared the way +/// reflection compares them, a constant by its value. A floating-point constant is compared bit by bit, because +/// 0.0 and -0.0 are equal as numbers and are written differently in the text of a query. +/// +[] +type internal ShapeToken = { + /// What the token says about its node. + Kind : ShapeTokenKind + /// The number that the kind gives a meaning to; 0 for a kind that has none. + Number : int + /// + /// The member, type or union case that the kind gives a meaning to; for a kind that + /// has none. + /// + Subject : objnull + /// + /// The value of a constant or the name of a slot; for a kind that has neither, for the + /// constant and for a slot without a name. + /// + Detail : objnull +} with + + /// + /// Whether and are the same token. + /// + static member private AreSame (first : ShapeToken, second : ShapeToken) : bool = + let sameDetail = + match first.Detail, second.Detail with + | (:? float as first), (:? float as second) -> + BitConverter.DoubleToInt64Bits first = BitConverter.DoubleToInt64Bits second + | (:? float32 as first), (:? float32 as second) -> + BitConverter.SingleToInt32Bits first = BitConverter.SingleToInt32Bits second + | first, second -> Object.Equals (first, second) + + first.Kind = second.Kind + && first.Number = second.Number + && Object.Equals (first.Subject, second.Subject) + && sameDetail + + /// + override token.Equals (other : objnull) : bool = + match other with + | :? ShapeToken as other -> ShapeToken.AreSame (token, other) + | _ -> false + + /// + override token.GetHashCode () : int = HashCode.Combine (int token.Kind, token.Number, token.Subject, token.Detail) + + /// The token as text, for the message of a failed assertion and for a debugger. + override token.ToString () : string = + let text = StringBuilder (string token.Kind) + + if + token.Number <> 0 + || token.Kind = ShapeTokenKind.Variable + || token.Kind = ShapeTokenKind.Slot + then + text.Append(' ').Append(token.Number) |> ignore + + match token.Subject with + | null -> () + | subject -> text.Append(' ').Append(subject) |> ignore + + match token.Kind, token.Detail with + | ShapeTokenKind.Constant, detail -> text.Append(" = ").Append($"%A{detail}") |> ignore + | _, null -> () + | _, detail -> text.Append(' ').Append(detail) |> ignore + + text.ToString () + + interface IEquatable with + + /// + member token.Equals (other : ShapeToken) : bool = ShapeToken.AreSame (token, other) + +/// +/// The shape of a quotation: everything in it that decides the text of the query, and nothing that only decides the +/// values of the parameters. Two quotations with equal keys give the same text, so the second one does not have to be +/// translated again. +/// +/// +/// +/// A quotation cannot be its own key. It compares its variables by identity, and every evaluation of a quotation +/// literal creates new variables, so no two evaluations of one literal are equal. It also compares the values it +/// captured, which are what a key has to leave out. +/// +/// +/// The key is the list of the nodes of the quotation, every node before the nodes under it. A variable is in it as +/// the distance to its binding, so the names of variables do not matter. A +/// is in it as its index, type and name, without its value. +/// +/// +[] +type internal ShapeKey = { + /// The nodes of the quotation, every node before the nodes under it. + Tokens : ImmutableArray + /// The hash code of the tokens, computed once when the key is made. + Hash : int +} with + + /// + /// Whether and are the same key. + /// + static member private AreSame (first : ShapeKey, second : ShapeKey) : bool = + // Spans, because the key that no code has filled holds an array that is not there, which a span reads as empty. + first.Hash = second.Hash + && MemoryExtensions.SequenceEqual (first.Tokens.AsSpan (), second.Tokens.AsSpan ()) + + /// + override key.Equals (other : objnull) : bool = + match other with + | :? ShapeKey as other -> ShapeKey.AreSame (key, other) + | _ -> false + + /// + override key.GetHashCode () : int = key.Hash + + /// The tokens as text, one on a line, for the message of a failed assertion and for a debugger. + override key.ToString () : string = + let text = StringBuilder () + + for token in key.Tokens.AsSpan () do + text.Append(token.ToString ()).Append('\n') |> ignore + + text.ToString () + + interface IEquatable with + + /// + member key.Equals (other : ShapeKey) : bool = ShapeKey.AreSame (key, other) + +/// +/// A place in a query for a value that is known before the query runs and is not a part of its text: a value that the +/// quotation captured from the code around it, or the value of a part of the quotation that reads nothing of the +/// document. The parameters of the query are made of the values of its slots. +/// +[] +type internal Slot = { + /// + /// The variable that stands for the value in the . + /// Its type is the type of the value. + /// + Variable : Var + /// The name of the captured variable that the value comes from; none for a value that is computed. + Name : string voption +} + +/// +/// What is known about a quotation without translating it: its +/// , by which a translation made earlier is found, and the +/// values to run that translation with. +/// +[] +type internal Shape = { + /// The shape of the quotation. + Key : ShapeKey + /// + /// The value of every , by the index of the slot. A slot has no + /// value when the quotation computes it only in a branch that it does not take this time: the query does not + /// take that branch either, so whatever stands in for the value there changes no result. + /// + Values : ImmutableArray +} + +/// +/// A quotation prepared for translation: what its holds, and the +/// quotation itself with a variable at every place where a value goes into the query as a parameter. +/// +[] +type internal Template = { + /// The shape of the quotation. + Key : ShapeKey + /// + /// The value of every slot, by the index of the slot: see + /// . + /// + Values : ImmutableArray + /// + /// The quotation with the variable of a at every place of a + /// value that is a parameter. Every value that is left in it is a part of the text of the query. + /// + Body : Expr + /// The slots, by their index. + Slots : ImmutableArray +} + +/// +/// Tells the shape of a quotation from the values it was written with: which values are parameters of the query, what +/// their values are this time, and what is left as the . +/// +/// +/// +/// The quotation has to be in the normal form that +/// gives. +/// +/// +/// These are the rules. +/// +/// +/// A literal is a part of the text of the query, and so of the key: a boolean, a character, a +/// string, an integer or a finite floating-point number of a built-in type, a value of an enumeration, the unit value +/// and . A value of one of these types that is declared with +/// is such a literal, because the compiler writes it into the +/// quotation as one. NaN and the infinities are no literals: the text of a query has no such number, so +/// they are slots. The default value of a type is the literal of that type when the type has one, as +/// Unchecked.defaultof<int> is zero; the default value of a date, a guid, a nullable or a union is data, +/// and a slot. +/// A decimal is not a literal, however it is written: the compiler writes 18m as a call +/// that makes the decimal, so it is computed like any call and is a slot. A parameter keeps its digits; a number in +/// the text of a query is read as a floating-point number. +/// A captured value is a named after its +/// variable. A value of another type that code put into a quotation it built is a slot without a +/// name. +/// A part that +/// +/// accepts, the largest one at its place, is computed and is a slot without a name: a property of a captured value, a +/// call, a module-level value. +/// A tuple, record, union case or array that the quotation builds stays what it is, with its parts +/// handled on their own, even when no part reads the document. The translator has to see that Some limit is an +/// option with a value, and that a list is written item by item. +/// and +/// say the opposite for their argument. A +/// constant has to be a value of one of the types of a literal: the key holds it, and equal keys have to mean one +/// text. +/// +/// +/// A slot stands for one node of the quotation, at every place the node is at. A value that a +/// bound is such a node: the normalizer writes the bound node at every place the value is used. +/// So the value is one slot, and its code runs once, as it does in compiled code, also when the places are inside +/// two different parts that are computed: in let limit = read () in p.Age > limit + 1 || p.Age < limit + 2 +/// both sums are slots of their own, and read is called once. One node at two places is one slot whatever put it +/// there: one quotation that is spliced into two places is one slot for both, with one value. +/// +/// +/// A captured variable that is used at several places is a slot at each of them. The compiler writes every use as a +/// node of its own, and nothing in those nodes says that they are one variable: two quotations that are spliced +/// together can each have captured a variable of the same name. Their values must not say it either. Were two such +/// nodes one slot whenever they hold one value, the key would depend on whether two values happen to be equal this +/// time, and one query would have two texts. A value that has to be one parameter is bound by a +/// inside the quotation. +/// +/// +/// A choice whose condition is known before the query runs computes only the parts of the branch it takes, as compiled +/// code does: in filter.IsNone || p.Name = filter.Value.Trim () nothing is trimmed when there is no filter. The +/// parts of the other branch are slots without a value. The key does not depend on which branch is taken. +/// +/// +[] +module internal Parameterizer = + + /// The reason a quotation has no shape, on its way out of the walk over the quotation. + [] + type private Refusal (error : TranslationError) = + inherit Exception (error.Message) + + /// The reason. + member _.Error = error + + /// + /// What a function of says about its argument. + /// + [] + type private Marker = + /// The argument is a part of the text of the query. + | AsConstant + /// The argument is a parameter of the query. + | AsParameter + + /// + /// The generic definition of the method that calls. + /// + let private calledDefinition (call : Expr) : MethodInfo = + match call with + | Call (None, method, _) -> method.GetGenericMethodDefinition () + | _ -> invalidArg (nameof call) $"The quotation is not a call of a function: %A{call}" + + /// + /// . + /// + let private constantFunction = calledDefinition <@ Query.constant 0 @> + + /// + /// . + /// + let private parameterFunction = calledDefinition <@ Query.parameter 0 @> + + /// + /// What says about its argument, when it is a function of + /// that says something. + /// + [] + let private (|MarkerFunction|_|) (method : MethodInfo) : Marker voption = + // The declaring type is compared first: it is one reference comparison, and it fails for nearly every method. + if Type.(=) (method.DeclaringType, constantFunction.DeclaringType) then + let token = method.MetadataToken + + if token = constantFunction.MetadataToken then + ValueSome AsConstant + elif token = parameterFunction.MetadataToken then + ValueSome AsParameter + else + ValueNone + else + ValueNone + + /// + /// Whether a null of the type is a literal: the null of a reference type that is no + /// union, and the unit value. A case of a union that is represented by null, as the None of an option is, is no + /// null: the compiler writes a case as a case. + /// + let private isLiteralNull (declared : Type) : bool = + not declared.IsValueType + && not (FSharpType.IsUnion (declared, true)) + + /// + /// Whether a value of the type can be a literal by its type alone: a boolean, a + /// character, a string, an integer or a floating-point number of a built-in type, and a value of an enumeration. + /// + /// + /// An enumeration has the type code of the number under it, and a nullable has the one of an object. There is no + /// decimal here: the compiler never writes one as a value. + /// + let private isLiteralType (declared : Type) : bool = + match Type.GetTypeCode declared with + | TypeCode.Boolean + | TypeCode.Char + | TypeCode.String + | TypeCode.SByte + | TypeCode.Byte + | TypeCode.Int16 + | TypeCode.UInt16 + | TypeCode.Int32 + | TypeCode.UInt32 + | TypeCode.Int64 + | TypeCode.UInt64 + | TypeCode.Single + | TypeCode.Double -> true + | _ -> false + + /// + /// Whether the compiler could have written into a quotation as a literal of the type + /// . Any other value without a name was put there by code that builds quotations, and + /// that code has no other way to pass data, so the value is taken for data. + /// + /// + /// The declared type decides, and not the type of the value: a nullable with a value is boxed as that value, and a + /// nullable without one is a null. So is a case of a union that is represented by null, as the None of an option + /// is. The compiler writes none of them as a value: a case of a union it writes as a case. + /// + let private isLiteral (value : objnull) (declared : Type) : bool = + match value with + | null -> isLiteralNull declared + | _ -> + // The text of a query has no NaN and no infinity: a number is digits with a fraction and an exponent. + match Type.GetTypeCode declared with + | TypeCode.Single -> Single.IsFinite (Convert.ToSingle value) + | TypeCode.Double -> Double.IsFinite (Convert.ToDouble value) + | _ -> isLiteralType declared + + /// + /// Whether the default value of is a literal: the zero of a number, false, the + /// character with the code zero, the value of an enumeration that has the number zero, and the null of a class that + /// is no union. The default value of any other type, such as a date, a guid, a nullable or a union, is data. + /// + /// + /// The type tells, and the default value is not made to ask it: a struct can have a constructor without + /// parameters, which the default value of the struct never runs and a value made by a constructor would. + /// + let private hasLiteralDefault (valueType : Type) : bool = isLiteralNull valueType || isLiteralType valueType + + /// + /// Whether is the type of F# functions or a class made of it, as the class of every + /// compiled function is and as a class that code declares can be. + /// + let rec private isFunctionClass (valueType : Type | null) : bool = + match valueType with + | null -> false + | valueType -> + (valueType.IsGenericType + && Type.(=) (valueType.GetGenericTypeDefinition (), typedefof<_ -> _>)) + || isFunctionClass valueType.BaseType + + /// + /// Whether a value of is a function or a delegate. + /// + let private isFunction (valueType : Type) : bool = + // A function and a delegate are objects, so a value type is neither, and nearly every slot is of one or a string. + not valueType.IsValueType + && (typeof.IsAssignableFrom valueType + || isFunctionClass valueType) + + /// + /// Whether a part of the type has a function or a delegate as its + /// although its type does not say so. Only an object and an interface can hold one + /// unseen, so a value of any other type is not looked at. + /// + let private isHiddenFunction (valueType : Type) (value : objnull) : bool = + (Type.(=) (valueType, typeof) || valueType.IsInterface) + && ( + match value with + | null -> false + | value -> isFunction (value.GetType ()) + ) + + /// + /// The error for a function value that would have to be a parameter of the query. + /// + let private functionValue (part : Expr) : TranslationError = + part + |> TranslationError.ofQuotation + TranslationErrorCode.CapturedFunctionValue + "A function that exists only as a compiled value is passed into the query. A query cannot use it, because its definition cannot be read, and a function is not a value that a parameter of a query can hold." + (ImmutableArray.Create( + "Mark the function with [], so that its definition can be read.", + "Or write the function as a quotation and splice it into the query with %." + )) + + /// + /// The error for an argument of a function of that is not + /// known before the query runs. + /// + let private notKnownBefore (marker : Marker) (call : Expr) : TranslationError = + let name = + match marker with + | AsConstant -> nameof Query.constant + | AsParameter -> nameof Query.parameter + + call + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + $"The argument of Query.%s{name} has to be known before the query runs, but it reads the document or holds a function written in the quotation." + (ImmutableArray.Create $"Pass Query.%s{name} a value that does not depend on the document.") + + /// + /// The error for an argument of that cannot + /// be written into the text of a query as a literal. + /// + let private notLiteral (valueType : Type) (call : Expr) : TranslationError = + call + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + $"The argument of Query.constant has to be a value that a query can hold as a literal: a boolean, a character, a string, an integer or a finite floating-point number of a built-in type, a value of an enumeration, or the null of a reference type that is no union of F#, as an option is. This one is a %s{valueType.Name}." + (ImmutableArray.Create + "Use the value without Query.constant: it becomes a parameter of the query, which holds a value of any type.") + + /// + /// The error for a variable that nothing in the quotation binds. + /// + let private unbound (variable : Var) (part : Expr) : TranslationError = + part + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + $"The quotation reads the variable '%s{variable.Name}', which nothing in it binds, so the variable has no value." + (ImmutableArray.Create + "Bind the variable with a function around the part that reads it, or put its value into the quotation.") + + /// + /// The error for a construct that is in no quotation in normal form except as a part that is not computed. + /// + let private inexpressible (part : Expr) : TranslationError = + part + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + "A query cannot express this part of the quotation: it is neither a value known before the query runs nor an operation on the document." + ImmutableArray.Empty + + /// + /// A slot that the walk has found. + /// + [] + type private Found = { + /// The part of the quotation that the slot stands for, by which another use of the very same part is told. + Part : Expr + /// The name of the captured variable; none for a value that is computed. + Name : string voption + /// The type of the value. + Type : Type + } + + /// + /// One walk over a quotation. It writes the tokens of the key and collects the slots with their values; when + /// is set, it also builds the quotation with a variable at the place of every slot. + /// + /// + /// Both results come from one walk, so that the key of a quotation is the same whether or not it is rebuilt. + /// Rebuilding is left out when the key is all that is asked for: building a node of a quotation costs microseconds, + /// and a quotation whose translation is already known needs no node built. + /// + [] + type private Walk (rebuild : bool) = + + let tokens = ImmutableArray.CreateBuilder 32 + let mutable hash = HashCode () + let values = ImmutableArray.CreateBuilder 4 + let found = ResizeArray 4 + let slots = ImmutableArray.CreateBuilder() + // The variables that the functions around the current node bind, the innermost one last. + let bound = ResizeArray 4 + // The nodes from the quotation down to the current node. When the walk is left, it tells where it was. + let path = ResizeArray 16 + // The parts that the evaluator has refused. The walk asks about a part and then about the parts under it, and + // the evaluator went down those parts to refuse the first one, so it answers for them from here. + let refused = Evaluator.Refused () + // What the walk has computed, node by node, so that a node that stands at several places is computed once, + // also when the places are inside different parts. + let computed = Evaluator.Computed () + // The node that was made a slot last, and the index of that slot: how a choice knows its condition. + let mutable latestPart : Expr | null = null + let mutable latestValue : objnull voption = ValueNone + + /// Writes a token into the key. + let emit (kind : ShapeTokenKind) (number : int) (subject : objnull) (detail : objnull) : unit = + let token = { Kind = kind; Number = number; Subject = subject; Detail = detail } + + tokens.Add token + hash.Add token + + /// Whether a part can be computed before the query runs. + let canCompute (part : Expr) : bool = Evaluator.canEvaluate refused part + + /// The value of a part that reads nothing of the document; leaves the walk when the code of the part raises. + let compute (part : Expr) : objnull = + match Evaluator.tryEvaluateOnce computed part with + | Ok value -> value + | Error error -> raise (Refusal error) + + /// The index of the slot that stands for this very part, or -1. + let indexOf (part : Expr) : int = + let mutable index = found.Count - 1 + + while index >= 0 + && not (obj.ReferenceEquals (found[index].Part, part)) do + index <- index - 1 + + index + + /// + /// The type of the value of a part that becomes a slot or a constant. A function is refused here, before + /// anything is computed for it. + /// + let valueTypeOf (part : Expr) : Type = + let valueType = part.Type + + if isFunction valueType then + raise (Refusal (functionValue part)) + + valueType + + /// + /// , the value of a part that becomes a slot or a constant. A function that is passed + /// as an object is refused here: the type of the part did not say what it is. + /// + let noFunction (part : Expr) (valueType : Type) (value : objnull) : objnull = + if isHiddenFunction valueType value then + raise (Refusal (functionValue part)) + + value + + /// The index of a new slot. + let add (part : Expr) (valueType : Type) (name : string voption) (value : objnull voption) : int = + let index = found.Count + + found.Add { Part = part; Name = name; Type = valueType } + + values.Add value + + if rebuild then + let variableName = + match name with + | ValueSome name -> name + | ValueNone -> $"p%d{index}" + + slots.Add { Variable = Var (variableName, valueType); Name = name } + + index + + /// + /// The index of the slot of a value that the quotation holds: a captured variable at one of the places it is + /// used at, which has a , or a value that code put into a quotation it built, which + /// has none. Another place is another slot unless it holds this very part: nothing else says that two parts + /// are one variable, and their values must not decide it, or the key would depend on them. + /// + let held (part : Expr) (name : string voption) (value : objnull) : int = + match indexOf part with + | -1 -> + let valueType = valueTypeOf part + add part valueType name (ValueSome (noFunction part valueType value)) + | index -> index + + /// + /// The index of the slot of a part that is computed. The part is computed when says + /// that the quotation takes the branch it is in, and once for all the places the very same part is at. + /// + let computed (live : bool) (part : Expr) : int = + match indexOf part with + | -1 -> + let valueType = valueTypeOf part + + add + part + valueType + ValueNone + (if live then + ValueSome (noFunction part valueType (compute part)) + else + ValueNone) + | index -> + // The part was met before in a branch that is not taken, and is met now where its value is needed. + if live && values[index].IsNone then + values[index] <- ValueSome (noFunction part found[index].Type (compute part)) + + index + + /// Writes the token of a slot; the node that stands at the place of the slot from now on. + let slot (index : int) (node : Expr) : Expr = + let entry = found[index] + + let name : objnull = + match entry.Name with + | ValueSome name -> name + | ValueNone -> null + + emit ShapeTokenKind.Slot index entry.Type name + latestPart <- node + latestValue <- values[index] + + if rebuild then Expr.Var slots[index].Variable else node + + /// Writes the token of a variable: how many bindings lie between the variable and its own. + let variable (bindingOf : Var) (node : Expr) : unit = + let mutable index = bound.Count - 1 + + while index >= 0 + && not (obj.ReferenceEquals (bound[index], bindingOf)) do + index <- index - 1 + + if index < 0 then + raise (Refusal (unbound bindingOf node)) + + emit ShapeTokenKind.Variable (bound.Count - 1 - index) null null + + /// + /// The value of the condition of a choice that has just been walked, when it is known: the condition is a slot + /// with a value. A literal is never a condition in normal form. + /// + let chosen (condition : Expr) : bool voption = + if obj.ReferenceEquals (latestPart, condition) then + match latestValue with + | ValueSome (:? bool as value) -> ValueSome value + | _ -> ValueNone + else + ValueNone + + /// + /// Walks and the nodes under it. says whether the quotation + /// takes the branch the node is in. The result is the node, or the node rebuilt when a slot is under it and + /// the walk rebuilds. + /// + let rec visit (live : bool) (node : Expr) : Expr = + path.Add node + let visited = inspect live node + path.RemoveAt (path.Count - 1) + visited + + /// What a visit does for a node, between entering it and leaving it. + and inspect (live : bool) (node : Expr) : Expr = + // The kinds of nodes that a query is mostly made of come first: every case that does not match costs a + // test, and a node is tested against the cases in their order. + match node with + | Var bindingOf -> + variable bindingOf node + node + | ValueWithName (value, _, name) -> slot (held node (ValueSome name) value) node + | Value (value, valueType) -> + if isLiteral value valueType then + // A literal that is not null is of no function type. A null is the literal of every class, of a + // function type too, and there it is refused as a function is: the query can use neither. + let valueType = + match value with + | null -> valueTypeOf node + | _ -> valueType + + emit ShapeTokenKind.Constant 0 valueType value + node + else + slot (held node ValueNone value) node + | PropertyGet (receiver, property, arguments) -> + if canCompute node then + slot (computed live node) node + else + emit ShapeTokenKind.PropertyGet 0 property null + members live node receiver arguments + | Call (receiver, method, arguments) -> + match method, arguments with + | MarkerFunction marker, [ argument ] -> marked live marker node argument + | _ when canCompute node -> slot (computed live node) node + | _ -> + emit ShapeTokenKind.Call 0 method null + members live node receiver arguments + | IfThenElse (condition, whenTrue, whenFalse) -> + if canCompute node then + slot (computed live node) node + else + emit ShapeTokenKind.IfThenElse 0 null null + let visitedCondition = visit live condition + + // A branch that the quotation does not take is still walked: the key holds both branches, + // whichever is taken this time. + let taken = if live then chosen condition else ValueNone + let visitedWhenTrue = visit (live && taken <> ValueSome false) whenTrue + let visitedWhenFalse = visit (live && taken <> ValueSome true) whenFalse + + if + obj.ReferenceEquals (visitedCondition, condition) + && obj.ReferenceEquals (visitedWhenTrue, whenTrue) + && obj.ReferenceEquals (visitedWhenFalse, whenFalse) + then + node + else + Expr.IfThenElse (visitedCondition, visitedWhenTrue, visitedWhenFalse) + | Lambda (parameter, body) -> + emit ShapeTokenKind.Lambda 0 parameter.Type null + bound.Add parameter + let visited = visit live body + bound.RemoveAt (bound.Count - 1) + + if obj.ReferenceEquals (visited, body) then + node + else + Expr.Lambda (parameter, visited) + | NewUnionCase (case, items) -> + emit ShapeTokenKind.NewUnionCase 0 case null + parts live node items + | NewTuple items -> + emit ShapeTokenKind.NewTuple 0 node.Type null + parts live node items + | NewRecord (recordType, items) -> + emit ShapeTokenKind.NewRecord 0 recordType null + parts live node items + | NewArray (itemType, items) -> + emit ShapeTokenKind.NewArray items.Length itemType null + parts live node items + | Coerce (value, targetType) -> + emit ShapeTokenKind.Coerce 0 targetType null + parts live node [ value ] + | DefaultValue defaultType -> + if canCompute node && not (hasLiteralDefault defaultType) then + slot (computed live node) node + else + // The default value of a function type is the null of it. + emit ShapeTokenKind.DefaultValue 0 (valueTypeOf node) null + node + | NewDelegate (delegateType, parameters, body) -> + emit ShapeTokenKind.NewDelegate parameters.Length delegateType null + bound.AddRange parameters + let visited = visit live body + bound.RemoveRange (bound.Count - parameters.Length, parameters.Length) + + if obj.ReferenceEquals (visited, body) then + node + else + Expr.NewDelegate (delegateType, parameters, visited) + // Every kind of node below is computed as a whole when the evaluator can compute it. + | _ when canCompute node -> slot (computed live node) node + | FieldGet (receiver, field) -> + emit ShapeTokenKind.FieldGet 0 field null + members live node receiver [] + | NewObject (constructor, arguments) -> + emit ShapeTokenKind.NewObject 0 constructor null + parts live node arguments + | TupleGet (tuple, index) -> + emit ShapeTokenKind.TupleGet index null null + parts live node [ tuple ] + | UnionCaseTest (union, case) -> + emit ShapeTokenKind.UnionCaseTest 0 case null + parts live node [ union ] + | TypeTest (value, testedType) -> + emit ShapeTokenKind.TypeTest 0 testedType null + parts live node [ value ] + | Application (func, argument) -> + emit ShapeTokenKind.Application 0 null null + parts live node [ func; argument ] + | _ -> raise (Refusal (inexpressible node)) + + /// + /// Walks the argument of a function of , which says what + /// the argument is. The call itself leaves no trace: it only says how its argument is read. + /// + and marked (live : bool) (marker : Marker) (call : Expr) (argument : Expr) : Expr = + match marker, argument with + | AsParameter, ValueWithName (value, _, name) -> slot (held argument (ValueSome name) value) call + | AsParameter, Value (value, _) -> slot (held argument ValueNone value) call + | AsParameter, _ when canCompute argument -> slot (computed live argument) call + | AsConstant, _ when canCompute argument -> + // The value is a part of the key, so it is computed whichever branch the call is in. + let valueType = valueTypeOf argument + let value = noFunction argument valueType (compute argument) + + // The key holds the value, and equal keys have to mean one text. Only a literal says by its equality + // what is written for it: an object is equal to itself after it has changed, and two objects can be + // equal and be written differently. + if not (isLiteral value valueType) then + raise (Refusal (notLiteral valueType call)) + + emit ShapeTokenKind.Constant 0 valueType value + latestPart <- call + latestValue <- ValueSome value + + if rebuild then Expr.Value (value, valueType) else call + | _ -> raise (Refusal (notKnownBefore marker call)) + + /// Walks the receiver and the arguments of a member. + and members (live : bool) (node : Expr) (receiver : Expr option) (arguments : Expr list) : Expr = + match receiver with + | Some receiver -> parts live node (receiver :: arguments) + | None -> parts live node arguments + + /// + /// Walks , the nodes under in their order. The result is the + /// node, or the node built anew over the items that the walk rebuilt. + /// + and parts (live : bool) (node : Expr) (items : Expr list) : Expr = + if rebuild then + let visited = items |> List.map (visit live) + + if List.forall2 (fun (item : Expr) (after : Expr) -> obj.ReferenceEquals (item, after)) items visited then + node + else + match node with + | ShapeCombination (shape, _) -> RebuildShapeCombination (shape, visited) + | _ -> node + else + for item in items do + visit live item |> ignore + + node + + /// + /// Walks , which the walk has not been used for before; the quotation, rebuilt when the + /// walk rebuilds. + /// + member _.Run (expr : Expr) : Expr = visit true expr + + /// + /// , which the walk was left with, with a place in the source: its own, or the place + /// of the nearest node around the part it is about that has one. A captured value has none of its own, and a + /// node that the normalizer built has the place of a part under it. + /// + member _.Located (error : TranslationError) : TranslationError = + if error.Location.IsSome then + error + else + let mutable index = path.Count - 1 + let mutable place = ValueNone + + while index >= 0 && place.IsNone do + place <- SourceRange.tryOfQuotation path[index] + index <- index - 1 + + { error with Location = place } + + /// The key of the quotation that was walked. + member _.Key : ShapeKey = { Tokens = tokens.ToImmutable (); Hash = hash.ToHashCode () } + + /// The values of the slots of the quotation that was walked. + member _.Values : ImmutableArray = values.ToImmutable () + + /// The slots of the quotation that was walked, when the walk rebuilds. + member _.Slots : ImmutableArray = slots.ToImmutable () + + /// + /// The key of , a quotation in normal form, and the values of its slots, or the reason it + /// has none. This is all that a quotation needs when its translation is known already. + /// + /// + /// These are errors: + /// + /// a part that has to be computed raised an exception, + /// ; + /// a function value would have to be a parameter, + /// ; + /// the argument of a function of depends + /// on the document, the argument of + /// is no value that a query can hold as a + /// literal, a variable is bound nowhere, or the quotation holds a construct that is neither a value nor an + /// operation on the document, . + /// + /// + /// + let shapeOf (expr : Expr) : Result = + let walk = Walk false + + try + walk.Run expr |> ignore + + Ok { Key = walk.Key; Values = walk.Values } + with :? Refusal as refusal -> + Error (walk.Located refusal.Error) + + /// + /// , a quotation in normal form, prepared for translation, or the reason it cannot be: + /// the errors of . + /// The key and the values are the ones that function gives. + /// + let templateOf (expr : Expr) : Result = + let walk = Walk true + + try + let body = walk.Run expr + + Ok { Key = walk.Key; Values = walk.Values; Body = body; Slots = walk.Slots } + with :? Refusal as refusal -> + Error (walk.Located refusal.Error) diff --git a/src/Cosmos.Quotations/Query.fs b/src/Cosmos.Quotations/Query.fs new file mode 100644 index 00000000..09c68faa --- /dev/null +++ b/src/Cosmos.Quotations/Query.fs @@ -0,0 +1,54 @@ +/// +/// Functions that say, inside a quotation, how a value gets into the query. +/// +/// +/// +/// A query is its text and the values of its parameters. A value that a quotation writes as a literal, such as +/// 18 in p.Age > 18, is a part of the text. A value that the quotation takes from the code around it +/// or computes from such values, such as limit in p.Age > limit, is a parameter: the text stays the +/// same when the value changes. +/// +/// +/// The functions here say the opposite for one value. Outside a quotation each of them returns its argument. +/// +/// +[] +module FSharp.Azure.Cosmos.Quotations.Query + +/// +/// Makes a part of the text of the query, although the quotation does not write it as a +/// literal: p.Kind = Query.constant kind. +/// +/// +/// +/// Every different value gives a query with a text of its own, which is translated on its own. So this is for a value +/// that takes few different values, never for a value that a user of the application enters. +/// +/// +/// The value has to be known before the query runs: it cannot depend on the document. And it has to be a value that a +/// query can hold as a literal: a boolean, a character, a string, an integer or a finite floating-point number of a +/// built-in type, a value of an enumeration or the of a reference type that is no union of F#: +/// a union that is represented by null, as an option is, has no null but a case without a value. A value of any other +/// type can only be a parameter: a decimal, a date, a number that is not finite, and a nullable or an option, with a +/// value or without one. +/// +/// +/// The value, which the quotation takes from the code around it or computes from such values. +/// . +let constant (value : 'T) : 'T = value + +/// +/// Makes a parameter of the query, although the quotation writes it as a literal: +/// p.Age > Query.parameter 18. +/// +/// +/// +/// Two queries that differ only in such a value have the same text, so the second one is not translated again. +/// +/// +/// The value has to be known before the query runs: it cannot depend on the document. +/// +/// +/// The value. +/// . +let parameter (value : 'T) : 'T = value diff --git a/src/Cosmos.Quotations/TranslationError.fs b/src/Cosmos.Quotations/TranslationError.fs index 5455ab9c..a658a454 100644 --- a/src/Cosmos.Quotations/TranslationError.fs +++ b/src/Cosmos.Quotations/TranslationError.fs @@ -35,9 +35,10 @@ type TranslationErrorCode = /// A construct of F# that a query has no counterpart for, such as a loop, an assignment or a recursive function. | Unsupported /// - /// A function that exists only as a compiled value is applied to a value of the document. A compiled function - /// cannot be read, so it cannot become a part of the query; a quotation or a function marked with - /// can. + /// A function that exists only as a compiled value is applied to a value of the document, or is passed into + /// the query as a value. A compiled function cannot be read, so it cannot become a part of the query, and it is + /// no value that a parameter of a query can hold; a quotation or a function marked with + /// can be read. /// | CapturedFunctionValue /// From 0f9552de4ede700efac0d1136b7da928bb4db174 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Mon, 12 Oct 2026 08:47:24 +0200 Subject: [PATCH 08/10] test(quotations): cover the parameterizer 47 functions of a person, every one of a shape of its own, are written twice over two sets of captured values; with the second set every choice takes its other branch. Five laws are checked on them: a function has one key and one hash code whatever values it captured, no two functions have one key, the key and the values are the same with and without the template, the template holds a variable for every slot and no captured value, and the template with the values put back computes what the compiled code computes. The compiler passes each function together with its quotation, and Unquote evaluates the template. The other tests state what the laws cannot: which values are slots, under which names and with which values, which default value is a literal and which is data, also for a struct whose constructor throws (a struct that F# cannot declare, which one helper makes at run time for this test and for the one of the evaluator), that two nodes are two slots whatever they hold, what is a part of the key, that a value which is bound once is computed once, that a quotation which is spliced into two places is one slot, that a branch that is not taken is not computed, what the functions of Query do, the tokens of a small key one by one, and every error. The check that tells which parts can be computed is tested with the evaluator: it accepts every part the evaluator computes, refuses a function, a variable and a quotation, and runs no code to tell. Co-Authored-By: Claude Opus 5.5 --- .../Cosmos.Quotations.Tests/DynamicStruct.fs | 41 + .../Cosmos.Quotations.Tests/EvaluatorTests.fs | 73 +- ...Sharp.Azure.Cosmos.Quotations.Tests.fsproj | 3 + tests/Cosmos.Quotations.Tests/Model.fs | 15 + .../ParameterizerShapeTests.fs | 303 +++++ .../ParameterizerTests.fs | 1195 +++++++++++++++++ .../QuotationAssert.fs | 75 +- .../Cosmos.Quotations.Tests/TestCategories.fs | 11 + 8 files changed, 1691 insertions(+), 25 deletions(-) create mode 100644 tests/Cosmos.Quotations.Tests/DynamicStruct.fs create mode 100644 tests/Cosmos.Quotations.Tests/ParameterizerShapeTests.fs create mode 100644 tests/Cosmos.Quotations.Tests/ParameterizerTests.fs diff --git a/tests/Cosmos.Quotations.Tests/DynamicStruct.fs b/tests/Cosmos.Quotations.Tests/DynamicStruct.fs new file mode 100644 index 00000000..f674b602 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/DynamicStruct.fs @@ -0,0 +1,41 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Reflection +open System.Reflection.Emit + +/// Structs that F# cannot declare, which a test makes at run time. +[] +module internal DynamicStruct = + + /// + /// A struct with one field of an integer, named Value, and a constructor without parameters, as C# can declare + /// one and F# cannot. The default value of such a struct is the one with every field zero: the constructor runs for + /// a value that makes, and never for the default + /// value. + /// + /// The name of the struct. + /// + /// Writes the code of the constructor, from its code generator and the field, up to and including the return or the + /// throw that ends it. + /// + let withConstructor (name : string) (writeConstructor : ILGenerator -> FieldInfo -> unit) : Type = + let declared = + AssemblyBuilder + .DefineDynamicAssembly(AssemblyName $"{name}.Dynamic", AssemblyBuilderAccess.Run) + .DefineDynamicModule("Structs") + .DefineType( + name, + TypeAttributes.Public + ||| TypeAttributes.Sealed + ||| TypeAttributes.SequentialLayout, + typeof + ) + + let field = declared.DefineField ("Value", typeof, FieldAttributes.Public) + + let code = + declared.DefineConstructor(MethodAttributes.Public, CallingConventions.Standard, Type.EmptyTypes).GetILGenerator() + + writeConstructor code field + declared.CreateType () diff --git a/tests/Cosmos.Quotations.Tests/EvaluatorTests.fs b/tests/Cosmos.Quotations.Tests/EvaluatorTests.fs index 54901a80..9d24a2b2 100644 --- a/tests/Cosmos.Quotations.Tests/EvaluatorTests.fs +++ b/tests/Cosmos.Quotations.Tests/EvaluatorTests.fs @@ -439,6 +439,50 @@ type EvaluatorTests () = "A version of FSharp.Core that keeps another operator from reflection needs another row in the evaluator." ) + [] + member _.``Every part that the evaluator computes must be told computable`` () = + let refused = + seq { + for computation in computations do + if not (Evaluator.canEvaluate (Evaluator.Refused ()) computation.Part) then + computation.Name + + for struct (name, part, _) in failures do + if not (Evaluator.canEvaluate (Evaluator.Refused ()) part) then + name + } + |> Seq.toArray + + Assert.IsEmpty ( + refused, + "A part that has a value, or that raises while it is computed, is made only of what the evaluator computes." + ) + + [] + member _.``A part that holds a function, a variable or a quotation must be told not computable, and none of it must run`` () = + let meter = Meter () + let variable = Expr.Var (Var ("number", typeof)) + + // In each of the first two the part before the one that cannot be computed can be: asking must not run it. + let withVariable = <@@ [| meter.Read 1; %%variable |] @@> + let withFunction = <@@ List.map (fun number -> number + 1) [ meter.Read 1 ] @@> + let quotation = Expr.QuoteTyped <@@ 1 @@> + + let refused = Evaluator.Refused () + + Assert.IsFalse (Evaluator.canEvaluate refused withVariable, "A variable has a value only inside the query.") + Assert.IsFalse (Evaluator.canEvaluate refused withFunction, "A function cannot be computed without compiling it.") + Assert.IsFalse (Evaluator.canEvaluate refused quotation, "A quotation inside the quotation is not computed.") + Assert.AreEqual(0, meter.Readings, "Asking whether a part can be computed should run no code of it.") + + Assert.IsFalse (Evaluator.canEvaluate refused withVariable, "A part that was refused stays refused.") + Assert.IsTrue (refused.Holds variable, "The variable is the reason, so it is remembered with the array around it.") + + match withVariable with + | NewArray (_, [ first; _ ]) -> + Assert.IsTrue (Evaluator.canEvaluate refused first, "The item before the variable can be computed on its own.") + | other -> Assert.Fail $"The quotation should be an array of two items: %A{other}" + [] member _.``A value that is bound once must be computed once for all its places in a part`` () = let meter = Meter () @@ -508,29 +552,16 @@ type EvaluatorTests () = member _.``The default value of a struct must be its zeroed value when the struct has a constructor without parameters`` () = // F# declares no struct with a constructor without parameters, as C# can, so the test makes one: its // constructor sets the field to 7. - let declared = - AssemblyBuilder - .DefineDynamicAssembly(AssemblyName "EvaluatorTests.Dynamic", AssemblyBuilderAccess.Run) - .DefineDynamicModule("Structs") - .DefineType( - "Seven", - TypeAttributes.Public - ||| TypeAttributes.Sealed - ||| TypeAttributes.SequentialLayout, - typeof + let seven = + DynamicStruct.withConstructor + "Seven" + (fun code field -> + code.Emit OpCodes.Ldarg_0 + code.Emit (OpCodes.Ldc_I4, 7) + code.Emit (OpCodes.Stfld, field) + code.Emit OpCodes.Ret ) - let field = declared.DefineField ("Value", typeof, FieldAttributes.Public) - - let code = - declared.DefineConstructor(MethodAttributes.Public, CallingConventions.Standard, Type.EmptyTypes).GetILGenerator() - - code.Emit OpCodes.Ldarg_0 - code.Emit (OpCodes.Ldc_I4, 7) - code.Emit (OpCodes.Stfld, field) - code.Emit OpCodes.Ret - - let seven = declared.CreateType () let valueOf (instance : objnull) = (nonNull (seven.GetField "Value")).GetValue instance Assert.AreEqual( diff --git a/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj b/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj index a7a238e8..20d866ec 100644 --- a/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj +++ b/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj @@ -32,7 +32,10 @@ + + + diff --git a/tests/Cosmos.Quotations.Tests/Model.fs b/tests/Cosmos.Quotations.Tests/Model.fs index c6a3e01e..6f93f0a0 100644 --- a/tests/Cosmos.Quotations.Tests/Model.fs +++ b/tests/Cosmos.Quotations.Tests/Model.fs @@ -120,6 +120,21 @@ type Folder = { | Some parent -> parent.Depth + 1 | None -> 0 +/// A function as a class that code declares; the class of every compiled function is made of the same type. +type TagTest (wanted : string) = + inherit FSharpFunc () + + /// + override _.Invoke (tag : string) : bool = tag = wanted + +/// A union with a case that is represented by null, as the None of an option is. +[] +type Rank = + /// The case that is null. + | Unranked + /// A case with a value. + | Ranked of int + /// A pass for values that counts them: a test tells by it how often a part of a quotation was computed. type Meter () = diff --git a/tests/Cosmos.Quotations.Tests/ParameterizerShapeTests.fs b/tests/Cosmos.Quotations.Tests/ParameterizerShapeTests.fs new file mode 100644 index 00000000..5620efcf --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/ParameterizerShapeTests.fs @@ -0,0 +1,303 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations +open FSharp.Quotations.Patterns + +open FSharp.Azure.Cosmos +open FSharp.Azure.Cosmos.Quotations + +/// The values that the functions of the tests capture. A test writes its functions over two sets of them. +type CapturedValues = { + Limit : int + Name : string + Filter : string option + Flag : bool + Nick : string option + Tags : string list + Range : AgeRange + Comparison : StringComparison +} + +/// +/// A function of a person as a quotation, with the check that another quotation computes what its compiled code does. +/// +type PersonFunction = { + /// What the function is made of; the name of a test result starts with it. + Name : string + /// The quotation of the function as it is written. + Quotation : Expr + /// Fails unless the function that a quotation holds computes what the compiled code of this function does. + ComputesTheSame : Expr -> unit +} with + + /// + /// The function . The compiler passes the code together with its quotation. + /// + static member Of<'Result when 'Result : equality> + (name : string, [] code : Expr 'Result>) + : PersonFunction + = + let code = Quoted.Split code + + { + Name = name + Quotation = code.Quotation + ComputesTheSame = NormalizerAssert.ComputesTheSame code.Compiled Persons.all + } + +/// The functions that the laws of the parameterizer are checked on. +[] +module PersonFunctions = + + /// + /// Functions of a person written over , every one of a shape of its own: no two of + /// them may give one query text. Two calls give the same functions in the same order, with other values. + /// + let over (captured : CapturedValues) : ImmutableArray = + // Locals, because a local arrives in a quotation as a value with the name of its variable. + let limit = captured.Limit + let name = captured.Name + let filter = captured.Filter + let flag = captured.Flag + let nick = captured.Nick + let tags = captured.Tags + let range = captured.Range + let comparison = captured.Comparison + + seq { + // Literals + PersonFunction.Of ("a literal", (fun p -> p.Age > 18)) + PersonFunction.Of ("another literal", (fun p -> p.Age > 21)) + PersonFunction.Of ("a literal of another type", (fun p -> int64 p.Age > 18L)) + PersonFunction.Of ("a zero", (fun p -> float p.Age > 0.0)) + PersonFunction.Of ("a negative zero", (fun p -> float p.Age > -0.0)) + PersonFunction.Of ("a string", (fun p -> p.Name = "Bob")) + PersonFunction.Of ("an empty string", (fun p -> p.Name = "")) + PersonFunction.Of ("null", (fun p -> box p.Name = null)) + PersonFunction.Of ("a character", (fun p -> p.Name.Contains 'o')) + PersonFunction.Of ("a value of an enumeration", (fun p -> p.Name.StartsWith ("b", StringComparison.Ordinal))) + PersonFunction.Of ( + "another value of the enumeration", + (fun p -> p.Name.StartsWith ("b", StringComparison.OrdinalIgnoreCase)) + ) + + // Captured values + PersonFunction.Of ("a captured value", (fun p -> p.Age > limit)) + PersonFunction.Of ("a captured value on the other side", (fun p -> limit < p.Age)) + PersonFunction.Of ("a captured value that is used twice", (fun p -> p.Age > limit || fst p.Scores > limit)) + PersonFunction.Of ("two captured values", (fun p -> p.Name = name || fst p.Scores > limit)) + PersonFunction.Of ("a captured value of an enumeration", (fun p -> p.Name.StartsWith (name, comparison))) + PersonFunction.Of ("a captured option", (fun p -> p.Nick = nick)) + PersonFunction.Of ("a captured list", (fun p -> tags |> List.contains p.Name)) + PersonFunction.Of ("a captured record", (fun p -> { Low = p.Age; High = fst p.Scores } = range)) + + // Parts that are computed + PersonFunction.Of ("a property of a captured value", (fun p -> p.Age >= range.Low)) + PersonFunction.Of ("a call on a captured value", (fun p -> p.Name = name.ToUpperInvariant ())) + PersonFunction.Of ("arithmetic on a captured value", (fun p -> p.Age <= limit + 1)) + PersonFunction.Of ("a module-level value", (fun p -> p.Age < Conditions.retirementAge)) + PersonFunction.Of ("a static field", (fun p -> p.Name <> String.Empty)) + PersonFunction.Of ( + "an object that a constructor makes", + (fun p -> DateTime (2000 + p.Age, 1, 1) > DateTime (2000 + limit, 1, 1)) + ) + + // Values that the quotation builds + PersonFunction.Of ("an option with a captured value", (fun p -> p.Nick = Some name)) + PersonFunction.Of ("an option with a literal", (fun p -> p.Nick = Some "bobby")) + PersonFunction.Of ("an option without a value", (fun p -> p.Nick = None)) + PersonFunction.Of ("a list that is written item by item", (fun p -> [ name; "Dee" ] |> List.contains p.Name)) + PersonFunction.Of ("an array", (fun p -> [| name; "Dee" |] |> Array.contains p.Name)) + PersonFunction.Of ("a longer array", (fun p -> [| name; "Dee"; "Cy" |] |> Array.contains p.Name)) + PersonFunction.Of ("a tuple", (fun p -> p.Scores = (limit, 1))) + PersonFunction.Of ("a struct tuple", (fun p -> struct (fst p.Scores, snd p.Scores) = struct (limit, 1))) + PersonFunction.Of ("a record", (fun p -> { Low = p.Age; High = limit } = { Low = 30; High = limit })) + PersonFunction.Of ("an anonymous record", (fun p -> {| Low = p.Age |} = {| Low = limit |})) + PersonFunction.Of ("a default value of a number", (fun p -> p.Age > Unchecked.defaultof)) + + // Choices + PersonFunction.Of ("a choice by a captured value", (fun p -> flag || p.Active)) + PersonFunction.Of ("a choice that guards a computed part", (fun p -> filter.IsNone || p.Name = filter.Value.Trim ())) + PersonFunction.Of ( + "a choice with a computed part in its other branch", + (fun p -> if flag then p.Age > limit else p.Name = filter.Value) + ) + PersonFunction.Of ("a choice by the document", (fun p -> if p.Active then p.Age > limit + 1 else p.Age < limit + 2)) + + // Other operations on the document + PersonFunction.Of ("an item of a tuple", (fun p -> fst p.Scores > limit)) + PersonFunction.Of ("another item of a tuple", (fun p -> snd p.Scores > limit)) + PersonFunction.Of ( + "a test for a union case", + (fun p -> + match p.Nick with + | Some _ -> p.Active + | None -> p.Age > limit + ) + ) + PersonFunction.Of ("a test for a type", (fun p -> box p.Age :? int)) + PersonFunction.Of ("a value seen as a value of another type", (fun p -> (p.Name :> obj) = (name :> obj))) + PersonFunction.Of ("an inner function", (fun p -> p.Tags |> List.exists (fun tag -> tag = name))) + PersonFunction.Of ( + "an inner function that reads the document", + (fun p -> p.Tags |> List.exists (fun tag -> tag = p.Name)) + ) + } + |> ImmutableArray.CreateRange + + /// The functions over values with which every choice takes its first branch. + let first = + over { + Limit = 18 + Name = "bob" + Filter = None + Flag = true + Nick = None + Tags = [] + Range = { Low = 10; High = 9 } + Comparison = StringComparison.Ordinal + } + + /// The same functions over other values, with which every choice takes its other branch. + let second = + over { + Limit = 30 + Name = "Bob" + Filter = Some " Bob " + Flag = false + Nick = Some "bobby" + Tags = [ "Bob"; "Dee" ] + Range = { Low = 30; High = 10 } + Comparison = StringComparison.OrdinalIgnoreCase + } + +/// +/// The laws of : the key of a function does not depend on +/// the values the function captured, two functions that are not alike have different keys, the key is the same whether +/// or not the template is asked for, and the template with its values computes what the function computes. +/// +[] +type ParameterizerShapeTests () = + + /// + /// Every function with both sets of values, as a row of a data-driven test. The name of a row replaces the name of + /// the test method in the results, so it says what the function is made of and what the + /// method asserts. + /// + static member private Rows (law : string) : IEnumerable> = seq { + for written in PersonFunctions.first do + TestDataRow(written, DisplayName = $"%s{written.Name} %s{law}, with the first values") + + for written in PersonFunctions.second do + TestDataRow(written, DisplayName = $"%s{written.Name} %s{law}, with the second values") + } + + /// The rows of the test that compares the keys of one function with two sets of values. + static member SameKeyRows : IEnumerable> = + Seq.zip PersonFunctions.first PersonFunctions.second + |> Seq.map (fun (struct (first, second)) -> + TestDataRow( + struct (first, second), + DisplayName = $"%s{first.Name} must have one key whatever values are captured" + ) + ) + + /// The rows of the test that compares what is known without the template with what the template holds. + static member SameShapeRows = ParameterizerShapeTests.Rows "must have the key and the values of its template" + + /// The rows of the test that looks at what the template holds at the places of the values. + static member VariableRows = + ParameterizerShapeTests.Rows "must have a template with a variable for every slot and no captured value" + + /// The rows of the test that compares the template with the compiled code. + static member SameMeaningRows = + ParameterizerShapeTests.Rows "must have a template that computes what the compiled code computes" + + [] + member _.``A function must have one key whatever values are captured`` (first : PersonFunction, second : PersonFunction) = + let firstKey = (ParameterizerAssert.WantShape first.Quotation).Key + let secondKey = (ParameterizerAssert.WantShape second.Quotation).Key + + Assert.AreEqual(firstKey, secondKey, "The values a function captured should not be in its key.") + + Assert.AreEqual( + firstKey.GetHashCode (), + secondKey.GetHashCode (), + "Equal keys should have one hash code, or a dictionary does not find the second one." + ) + + [] + member _.``Two functions that are not alike must have different keys`` () = + let keys = + PersonFunctions.first + |> Seq.map (fun written -> struct (written.Name, (ParameterizerAssert.WantShape written.Quotation).Key)) + |> Seq.toArray + + let alike = + seq { + for index in 0 .. keys.Length - 1 do + for other in index + 1 .. keys.Length - 1 do + let struct (name, key) = keys[index] + let struct (otherName, otherKey) = keys[other] + + if key = otherKey then + $"%s{name} / %s{otherName}" + } + |> Seq.toArray + + let listed = String.Join (", ", alike) + + Assert.IsEmpty ( + alike, + $"Functions with one key get one query text, so every pair here would share a wrong one: %s{listed}." + ) + + [] + member _.``A function must have the key and the values of its template`` (written : PersonFunction) = + let shape = ParameterizerAssert.WantShape written.Quotation + let template = ParameterizerAssert.WantTemplate written.Quotation + + Assert.AreEqual( + template.Key, + shape.Key, + "The key that finds a translation should be the key the translation was made under." + ) + + CollectionAssert.AreEqual ( + template.Values |> Seq.toArray, + shape.Values |> Seq.toArray, + "The values should be the same, slot by slot." + ) + + Assert.HasCount (template.Slots.Length, shape.Values, "Every slot should have its place among the values.") + + [] + member _.``A function must have a template with a variable for every slot and no captured value`` (written : PersonFunction) = + let template = ParameterizerAssert.WantTemplate written.Quotation + + let captured = + template.Body + |> Quotation.filter (fun part -> + match part with + | ValueWithName _ -> true + | _ -> false + ) + + Assert.IsEmpty (captured, "A captured value is a parameter, so the template should hold a variable at its place.") + + CollectionAssert.AreEquivalent ( + template.Slots |> Seq.map _.Variable |> Seq.toArray, + template.Body.GetFreeVars () |> Seq.toArray, + "The variables that the template leaves unbound should be the variables of its slots, every one of them." + ) + + [] + member _.``A function must have a template that computes what the compiled code computes`` (written : PersonFunction) = + written.Quotation + |> ParameterizerAssert.WantTemplate + |> Templates.withValues + |> written.ComputesTheSame diff --git a/tests/Cosmos.Quotations.Tests/ParameterizerTests.fs b/tests/Cosmos.Quotations.Tests/ParameterizerTests.fs new file mode 100644 index 00000000..3256a363 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/ParameterizerTests.fs @@ -0,0 +1,1195 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Linq +open System.Reflection.Emit +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations +open FSharp.Quotations.Patterns + +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// Values declared as literals, which the compiler writes into a quotation in place of their names. +module Literals = + + /// The first letter of a name. + [] + let Initial = "B" + + /// A rate, as a decimal. + [] + let Rate = 2.5m + +/// +/// What makes of the values in a quotation: which of them +/// are slots, under which names and with which values, which are parts of the key, and what is an error. +/// +[] +type ParameterizerTests () = + + /// The value of a slot, which a test expects to have been computed. + static let valueOf (index : int) (values : Collections.Immutable.ImmutableArray) : objnull = + Assert.WantValueSome (values[index], $"The slot %d{index} is in a branch that is taken, so it should have a value.") + + /// The module of the functions that say how a value gets into the query. + static let queryModule = + match <@ Query.constant 0 @> with + | Call (None, method, _) -> method.DeclaringType + | other -> invalidOp $"The quotation is not a call of a function: %A{other}" + + /// Whether a quotation calls a function of the Query module. + static let callsQuery (expr : Expr) : bool = + expr + |> Quotation.exists (fun part -> + match part with + | Call (None, method, _) -> Type.(=) (method.DeclaringType, queryModule) + | _ -> false + ) + + /// A quotation with a value of its own under the name that every quotation made here gives its value. + static let olderThan (age : int) : Expr bool> = <@ fun person -> person.Age > age @> + + /// A quotation that captures a name. + static let named (name : string) : Expr bool> = <@ fun person -> person.Name = name @> + + /// Another quotation that captures a variable of the same name. + static let nicknamed (name : string) : Expr bool> = <@ fun person -> person.Nick = Some name @> + + /// Quotations that build a value from a captured name, each with the types of the slots it has to give. + static member BuiltValueRows : IEnumerable> = + let name = "Bob" + let limit = 30 + + seq { + struct ("An option", <@@ fun (p : Person) -> p.Nick = Some name @@>, [| typeof |]) + struct ("A list", <@@ fun (p : Person) -> [ name; "Dee" ] |> List.contains p.Name @@>, [| typeof |]) + struct ("An array", <@@ fun (p : Person) -> [| name; "Dee" |] |> Array.contains p.Name @@>, [| typeof |]) + struct ("A tuple", <@@ fun (p : Person) -> p.Scores = (limit, 1) @@>, [| typeof |]) + struct ("A struct tuple", + <@@ fun (p : Person) -> struct (p.Name, p.Age) = struct (name, limit) @@>, + [| typeof; typeof |]) + struct ("A record", + <@@ fun (p : Person) -> { Low = p.Age; High = 1 } = { Low = limit; High = 1 } @@>, + [| typeof |]) + struct ("An anonymous record", + <@@ fun (p : Person) -> {| Name = p.Name |} = {| Name = name |} @@>, + [| typeof |]) + } + |> Seq.map (fun (struct (built, quotation, slots)) -> + TestDataRow( + struct (quotation, slots), + DisplayName = $"%s{built} that the quotation builds must stay what it is, with its parts as slots" + ) + ) + + /// Quotations that pass a function value where the query would need to read the function. + static member FunctionValueRows : IEnumerable> = + let isVip = fun (tag : string) -> tag = "vip" + let isNew = Func(fun tag -> tag = "new") + let hiddenFunction : obj = isVip + let hiddenDelegate : obj = isNew + let ownFunction = TagTest "vip" + + seq { + struct ("A captured function that is passed into the query", <@@ fun (p : Person) -> p.Tags |> List.exists isVip @@>) + struct ("A captured delegate that is passed into the query", + <@@ fun (p : Person) -> Enumerable.Any (p.Tags, isNew) @@>) + struct ("A function that a call returns into the query", + <@@ fun (p : Person) -> [ p ] |> List.exists (Conditions.olderThan 18) @@>) + struct ("A module-level function value that is passed into the query", + <@@ fun (p : Person) -> [ p ] |> List.exists Conditions.isSenior @@>) + + // The type of the part does not say that the value is a function + struct ("A captured function that is passed as an object", + <@@ fun (p : Person) -> Object.Equals (p.Tags, hiddenFunction) @@>) + struct ("A captured delegate that is passed as an object", + <@@ fun (p : Person) -> Object.Equals (p.Tags, hiddenDelegate) @@>) + struct ("A function that a call returns as an object", + <@@ fun (p : Person) -> Object.Equals (p.Tags, box (Conditions.olderThan 18)) @@>) + + // The type of the part is a class made of the type of functions + struct ("A captured function of a class that code declares", + <@@ fun (p : Person) -> Object.Equals (p.Tags, ownFunction) @@>) + + // A function is no constant of a query either + struct ("A function that Query.constant is given", + <@@ fun (p : Person) -> p.Tags |> List.exists (Query.constant isVip) @@>) + struct ("A function that Query.constant is given as an object", + <@@ fun (p : Person) -> Object.Equals (p.Tags, Query.constant hiddenFunction) @@>) + + // A function that is not there is no value of a query either. Only code builds these two: the compiler + // writes no null of a function type. + struct ("The null of a function type that code builds into the query", + <@@ + fun (p : Person) -> + p.Tags + |> List.exists %%(Expr.Value (null, typeof bool>)) + @@>) + struct ("The default value of a function type that code builds into the query", + <@@ + fun (p : Person) -> + p.Tags + |> List.exists %%(Expr.DefaultValue typeof bool>) + @@>) + } + |> Seq.map (fun (struct (passed, quotation)) -> + TestDataRow(quotation, DisplayName = $"%s{passed} must be reported") + ) + + /// Quotations that give Query.constant a value that a query cannot hold as a literal. + static member NotLiteralRows : IEnumerable> = + let range = { Low = 1; High = 2 } + let tags = [| "vip" |] + let rate = 2.5m + let day = DateTime (2026, 1, 1) + let address = Uri "http://localhost" + let count = Nullable 5 + let noCount = Nullable() + let nobody : string option = None + let unranked = Unranked + let notANumber = Double.NaN + let boundless = Double.NegativeInfinity + let smallNotANumber = Single.NaN + + seq { + struct ("A record", <@@ fun (p : Person) -> { Low = p.Age; High = 2 } = Query.constant range @@>) + struct ("An array", <@@ fun (p : Person) -> Query.constant tags |> Array.contains p.Name @@>) + struct ("A decimal", <@@ fun (p : Person) -> decimal p.Age > Query.constant rate @@>) + struct ("A date", <@@ fun (p : Person) -> DateTime (2000 + p.Age, 1, 1) > Query.constant day @@>) + struct ("An object", <@@ fun (p : Person) -> Object.Equals (p.Name, Query.constant address) @@>) + struct ("A nullable with a value", <@@ fun (p : Person) -> Nullable p.Age = Query.constant count @@>) + struct ("A nullable without a value", <@@ fun (p : Person) -> Nullable p.Age = Query.constant noCount @@>) + struct ("An option without a value", <@@ fun (p : Person) -> p.Nick = Query.constant nobody @@>) + struct ("A case of a union that is null", <@@ fun (p : Person) -> Object.Equals (p.Name, Query.constant unranked) @@>) + struct ("NaN", <@@ fun (p : Person) -> float p.Age > Query.constant notANumber @@>) + struct ("An infinity", <@@ fun (p : Person) -> float p.Age > Query.constant boundless @@>) + struct ("A NaN of a single", <@@ fun (p : Person) -> float32 p.Age > Query.constant smallNotANumber @@>) + } + |> Seq.map (fun (struct (given, quotation)) -> + TestDataRow(quotation, DisplayName = $"%s{given} that Query.constant is given must be reported") + ) + + // Slots + + [] + member _.``A captured value must be a slot that is named after its variable`` () = + let limit = 18 + let template = ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > limit @> + + let slot = Assert.ContainsSingle (template.Slots, "The quotation captures one value.") + Assert.AreEqual(ValueSome "limit", slot.Name, "The slot should have the name of the variable.") + Assert.AreEqual(typeof, slot.Variable.Type, "The variable of the slot should have the type of the value.") + Assert.AreEqual(18, valueOf 0 template.Values, "The value of the slot should be the captured value.") + + [] + member _.``A captured variable that is used twice must be a slot at each place`` () = + let limit = 18 + let name = "Bob" + + let ofValueType = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > limit || fst p.Scores > limit @> + let ofReferenceType = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Name = name || p.Nick = Some name @> + + CollectionAssert.AreEqual ( + [| ValueSome "limit"; ValueSome "limit" |], + ofValueType.Slots |> Seq.map _.Name |> Seq.toArray, + "The compiler writes each use as a node of its own, and nothing in the nodes says that they are one variable." + ) + + CollectionAssert.AreEqual ( + [| box 18; box 18 |], + [| valueOf 0 ofValueType.Values; valueOf 1 ofValueType.Values |], + "Each slot should hold the value of the variable." + ) + + Assert.HasCount (2, ofReferenceType.Slots, "Two nodes that hold one object are two slots like any two nodes.") + + [] + member _.``Two captured variables of one name must be two slots whatever they hold`` () = + // Each splice captured its own variable `age`. + let both (first : int) (second : int) = <@ fun (p : Person) -> (%olderThan first) p && (%olderThan second) p @> + + let different = ParameterizerAssert.WantTemplate (both 18 65) + let same = ParameterizerAssert.WantTemplate (both 18 18) + + CollectionAssert.AreEqual ( + [| ValueSome "age"; ValueSome "age" |], + different.Slots |> Seq.map _.Name |> Seq.toArray, + "Each slot should keep the name of its variable." + ) + + CollectionAssert.AreEqual ( + [| box 18; box 65 |], + [| valueOf 0 different.Values; valueOf 1 different.Values |], + "The slots should hold the two values in the order of their first use." + ) + + Assert.HasCount (2, same.Slots, "Two variables stay two parameters when they happen to hold one value.") + + Assert.AreEqual( + different.Key, + same.Key, + "The key should not say whether two values are equal this time, or one query would have two texts." + ) + + [] + member _.``Two captured variables of one name must be two slots when they hold one object`` () = + // Each splice captured its own variable `name`, and both variables hold the same string. + let text = "Bob" + let template = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> (%named text) p || (%nicknamed text) p @> + + CollectionAssert.AreEqual ( + [| ValueSome "name"; ValueSome "name" |], + template.Slots |> Seq.map _.Name |> Seq.toArray, + "What two variables hold does not make them one: the next time they can hold two objects." + ) + + [] + member _.``Two captured variables of one value must be two slots when their names differ`` () = + let low = 18 + let high = 18 + let template = ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age >= low && p.Age <= high @> + + CollectionAssert.AreEqual ( + [| ValueSome "low"; ValueSome "high" |], + template.Slots |> Seq.map _.Name |> Seq.toArray, + "Two variables are two parameters, also when they happen to hold one value." + ) + + [] + member _.``A captured value that is bound by let must be one slot for all its uses`` () = + let limit = 18 + + let template = + ParameterizerAssert.WantTemplate + <@ + fun (p : Person) -> + let age = limit + p.Age > age || fst p.Scores > age + @> + + let slot = + Assert.ContainsSingle ( + template.Slots, + "The normalizer writes the bound node at both places, and one node is one slot." + ) + + Assert.AreEqual(ValueSome "limit", slot.Name, "The slot should have the name of the captured variable.") + + [] + member _.``A quotation that is spliced into two places must be one slot for both`` () = + let limit = 18 + + // The quotation binds a value, so the normalizer rewrites it before the slots are told. + let age = + <@ + let years = limit + years + 1 + @> + + let template = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > %age || fst p.Scores > %age @> + + Assert.ContainsSingle ( + template.Slots, + "A splice puts one node at both places, the normalizer keeps it one node, and one node is one slot." + ) + |> ignore + + Assert.AreEqual(19, valueOf 0 template.Values, "The slot should hold the value that the spliced code computes.") + + [] + member _.``The name of a captured variable must be in the key`` () = + let keyOf (expr : Expr) = (ParameterizerAssert.WantShape expr).Key + let limit = 18 + let minimum = 18 + + Assert.AreNotEqual( + keyOf <@ fun (p : Person) -> p.Age > limit @>, + keyOf <@ fun (p : Person) -> p.Age > minimum @>, + "The parameter of a query is named after the variable, so another name is another query text." + ) + + [] + member _.``The type of a slot must be in the key`` () = + let keyOf (expr : Expr) = (ParameterizerAssert.WantShape expr).Key + + let ofAddress = + let value = Uri "http://localhost" + keyOf <@ fun (p : Person) -> Object.Equals (p.Name, value) @> + + let ofText = + let value = "5" + keyOf <@ fun (p : Person) -> Object.Equals (p.Name, value) @> + + Assert.AreNotEqual(ofAddress, ofText, "A value of another type is written into the query in another way.") + + [] + member _.``The index of a slot must be in the key`` () = + let limit = 18 + + // The same condition twice; the second one binds the value, so it is one slot at both places. + let ofTwoSlots = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > limit || fst p.Scores > limit @> + + let ofOneSlot = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let limit = limit + p.Age > limit || fst p.Scores > limit + @> + + Assert.HasCount (2, ofTwoSlots.Values, "Two uses of a captured variable are two slots.") + + Assert.ContainsSingle (ofOneSlot.Values, "A bound value is one slot at all its places.") + |> ignore + + Assert.AreNotEqual( + ofTwoSlots.Key, + ofOneSlot.Key, + "One parameter at two places and two parameters are different query texts, and they take a different number of values." + ) + + [] + member _.``A part that reads no variable must be one slot without a name`` () = + let limit = 18 + let template = ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > (limit + 1) * 2 @> + + let slot = + Assert.ContainsSingle (template.Slots, "The largest part that can be computed should be one slot.") + Assert.AreEqual(ValueNone, slot.Name, "A computed value has no variable to be named after.") + Assert.AreEqual(38, valueOf 0 template.Values, "The slot should hold what the part computes.") + + [] + member _.``A choice that reads nothing of the document must be one slot`` () = + let shapeOf (filter : string option) = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Name = (if filter.IsNone then "" else filter.Value.Trim ()) @> + + let without = shapeOf None + let withFilter = shapeOf (Some " Bob ") + + CollectionAssert.AreEqual ( + [| ValueSome (box "") |], + without.Values |> Seq.toArray, + "The choice is computed as a whole, as compiled code computes it: nothing is trimmed without a filter." + ) + + CollectionAssert.AreEqual ( + [| ValueSome (box "Bob") |], + withFilter.Values |> Seq.toArray, + "The choice is one value, so it is one slot, whichever branch gives the value." + ) + + Assert.AreEqual(without.Key, withFilter.Key, "The key should not say which branch gave the value.") + + [] + member _.``A module-level value must be a slot`` () = + let shape = ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > Conditions.retirementAge @> + + Assert.ContainsSingle (shape.Values, "The value is read before the query runs.") + |> ignore + + Assert.AreEqual(65, valueOf 0 shape.Values, "The slot should hold the value of the module.") + + [] + member _.``A value bound by let must be computed once for all its uses`` () = + let meter = Meter () + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let limit = meter.Read 18 + p.Age > limit || fst p.Scores > limit + @> + + Assert.ContainsSingle (shape.Values, "The normalizer writes the bound value at both places, and it is one value.") + |> ignore + + Assert.AreEqual(1, meter.Readings, "The code of the value should run once.") + + [] + member _.``Values bound by two lets must each be computed once for all their uses`` () = + let low = Meter () + let high = Meter () + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let least = low.Read 18 + let most = high.Read 65 + (p.Age > least && p.Age < most) + || (fst p.Scores > least && fst p.Scores < most) + @> + + Assert.HasCount ( + 2, + shape.Values, + "Each bound value should stay one node when the other one is written into the quotation." + ) + + Assert.AreEqual(1, low.Readings, "The code of the value that is bound first should run once.") + Assert.AreEqual(1, high.Readings, "The code of the value that is bound second should run once.") + + [] + member _.``A value bound by let must be computed once when two computed parts read it`` () = + let meter = Meter () + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let limit = meter.Read 18 + p.Age > limit + 1 || fst p.Scores > limit + 2 + @> + + CollectionAssert.AreEqual ( + [| ValueSome (box 19); ValueSome (box 20) |], + shape.Values |> Seq.toArray, + "Each sum is the largest part at its place that can be computed, so each is a slot of its own." + ) + + Assert.AreEqual(1, meter.Readings, "Both sums read the one value that was bound, whose code should run once.") + + [] + member _.``A value bound by let must be computed once when a later value reads it`` () = + let meter = Meter () + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let limit = meter.Read 18 + let twice = limit * 2 + (p.Age > limit && p.Age < twice) + || (fst p.Scores > limit && fst p.Scores < twice) + @> + + CollectionAssert.AreEqual ( + [| ValueSome (box 18); ValueSome (box 36) |], + shape.Values |> Seq.toArray, + "The value and what is made of it are one slot each, however often they are used." + ) + + Assert.AreEqual(1, meter.Readings, "The code of the first value should run once, also for the value made of it.") + + // Literals + + [] + member _.``A literal must be a part of the key and no slot`` () = + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + p.Age > 18 + && float p.Age > 0.5 + && p.Name <> "" + && p.Name.Contains 'o' + && p.Name.StartsWith ("B", StringComparison.Ordinal) + && box p.Nick <> null + && ignore p.Age = () + @> + + Assert.IsEmpty (shape.Values, "A literal is a part of the query text, whatever its type is.") + + [] + member _.``A decimal that is written must be a slot, also when it is declared as a literal`` () = + // The compiler writes a decimal as a call that makes it, never as a value. + let written = ParameterizerAssert.WantShape <@ fun (price : decimal) -> price > 18.5m @> + let declared = ParameterizerAssert.WantShape <@ fun (price : decimal) -> price > Literals.Rate @> + + CollectionAssert.AreEqual ( + [| ValueSome (box 18.5m) |], + written.Values |> Seq.toArray, + "A decimal should be a parameter, which keeps its digits." + ) + + CollectionAssert.AreEqual ( + [| ValueSome (box 2.5m) |], + declared.Values |> Seq.toArray, + "A decimal that is declared as a literal is written into the quotation the same way." + ) + + Assert.AreEqual(written.Key, declared.Key, "Two decimals are two values of one query text.") + + [] + member _.``A value declared as a literal must be the literal`` () = + let declared = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Name.StartsWith (Literals.Initial, StringComparison.Ordinal) @> + + let written = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Name.StartsWith ("B", StringComparison.Ordinal) @> + + Assert.IsEmpty (declared.Values, "The compiler writes the value into the quotation, so it is no slot.") + Assert.AreEqual(written.Key, declared.Key, "The declared literal and the written one are one quotation.") + + [] + member _.``A value that code put into a quotation must be a slot unless the compiler could have written it`` () = + let id = Guid.NewGuid () + let ofData = + ParameterizerAssert.WantTemplate <@ fun (documentId : Guid) -> documentId = %%(Expr.Value id) @> + let ofLiteral = ParameterizerAssert.WantTemplate <@ fun (age : int) -> age = %%(Expr.Value 5) @> + + let slot = Assert.ContainsSingle (ofData.Slots, "No literal is a Guid, so the value is data.") + Assert.AreEqual(ValueNone, slot.Name, "A value without a variable has no name.") + Assert.AreEqual(id, valueOf 0 ofData.Values, "The slot should hold the value.") + Assert.IsEmpty (ofLiteral.Slots, "A number cannot be told from a literal, so it is one.") + + [] + member _.``A number that is not finite must be a slot when code put it into a quotation, and a finite one a literal`` () = + // The text of a query has no NaN and no infinity, so a part of the key cannot be one. + let ofFinite = ParameterizerAssert.WantTemplate <@ fun (age : float) -> age = %%(Expr.Value 2.5) @> + Assert.IsEmpty (ofFinite.Slots, "A finite number is a literal, which the compiler could have written.") + + for value in + seq { + Double.NaN + Double.PositiveInfinity + Double.NegativeInfinity + } do + let template = ParameterizerAssert.WantTemplate <@ fun (age : float) -> age = %%(Expr.Value value) @> + let slot = + Assert.ContainsSingle (template.Slots, $"%f{value} cannot be written into the text of a query.") + Assert.AreEqual(typeof, slot.Variable.Type, "The slot should have the type of the node.") + Assert.AreEqual(value, valueOf 0 template.Values, "The slot should hold the value.") + + let single = + ParameterizerAssert.WantTemplate <@ fun (age : float32) -> age = %%(Expr.Value Single.NaN) @> + Assert.ContainsSingle (single.Slots, "The NaN of a single is data too.") + |> ignore + + let finiteSingle = + ParameterizerAssert.WantTemplate <@ fun (age : float32) -> age = %%(Expr.Value 2.5f) @> + Assert.IsEmpty (finiteSingle.Slots, "A finite single is a literal.") + + [] + member _.``The default value of a type that has no literal must be a slot, and that of a type that has one a literal`` () = + // The compiler writes Unchecked.defaultof and Guid () as the default value of the type, a node of its own. + let ofDate = + ParameterizerAssert.WantTemplate <@ fun (created : DateTime) -> created = %%(Expr.DefaultValue typeof) @> + + let ofGuid = + ParameterizerAssert.WantTemplate <@ fun (id : Guid) -> id = %%(Expr.DefaultValue typeof) @> + + let ofNullable = + ParameterizerAssert.WantTemplate <@ fun (age : Nullable) -> age = %%(Expr.DefaultValue typeof>) @> + + let ofUnion = + ParameterizerAssert.WantTemplate <@ fun (rank : Rank) -> rank = %%(Expr.DefaultValue typeof) @> + + let slotOfDate = Assert.ContainsSingle (ofDate.Slots, "The default value of a date is data.") + Assert.AreEqual(typeof, slotOfDate.Variable.Type, "The slot should have the type of the node.") + Assert.AreEqual(box (DateTime ()), valueOf 0 ofDate.Values, "The slot should hold the default value.") + + Assert.ContainsSingle (ofGuid.Slots, "The default value of a guid is data.") + |> ignore + Assert.AreEqual(box Guid.Empty, valueOf 0 ofGuid.Values, "The slot should hold the empty guid.") + + Assert.ContainsSingle (ofNullable.Slots, "The default value of a nullable is no literal.") + |> ignore + Assert.IsNull (valueOf 0 ofNullable.Values, "The slot should hold the null that the nullable is.") + + Assert.ContainsSingle (ofUnion.Slots, "The default value of a union is the null of the union, which is data.") + |> ignore + + let ofNumber = + ParameterizerAssert.WantTemplate <@ fun (age : int) -> age = %%(Expr.DefaultValue typeof) @> + + let ofText = + ParameterizerAssert.WantTemplate <@ fun (name : string) -> name = %%(Expr.DefaultValue typeof) @> + + let ofFloat = + ParameterizerAssert.WantTemplate <@ fun (rate : float) -> rate = %%(Expr.DefaultValue typeof) @> + + let ofSingle = + ParameterizerAssert.WantTemplate <@ fun (rate : float32) -> rate = %%(Expr.DefaultValue typeof) @> + + Assert.IsEmpty (ofNumber.Slots, "The default value of a number is zero, a literal.") + Assert.IsEmpty (ofFloat.Slots, "The default value of a floating-point number is zero, a literal.") + Assert.IsEmpty (ofSingle.Slots, "The default value of a single is zero, a literal.") + Assert.IsEmpty (ofText.Slots, "The default value of a string is null, a literal.") + + [] + member _.``The default value of a struct must be a slot that holds the zeroed struct whatever its constructor does`` () = + // The constructor of this struct throws. Asking whether its default value is a literal must not run it, as making + // a value would, and the value that the slot holds is the one that compiled code has: every field zero. + let throwing = + DynamicStruct.withConstructor + "Throwing" + (fun code _ -> + code.Emit (OpCodes.Ldstr, "The constructor of the struct must not run.") + code.Emit (OpCodes.Newobj, nonNull (typeof.GetConstructor [| typeof |])) + code.Emit OpCodes.Throw + ) + + let template = ParameterizerAssert.WantTemplate (Expr.DefaultValue throwing) + let slot = + Assert.ContainsSingle (template.Slots, "The default value of a struct of an application is data.") + + Assert.AreEqual(throwing, slot.Variable.Type, "The slot should have the type of the struct.") + + Assert.AreEqual( + box 0, + (nonNull (throwing.GetField "Value")).GetValue(valueOf 0 template.Values), + "The slot should hold the zeroed struct: no constructor runs for a default value." + ) + + [] + member _.``A nullable that code put into a quotation must be a slot, with a value and without one`` () = + // A nullable with a value is boxed as the value, so only the type of the node says that it is a nullable. + let withValue = + ParameterizerAssert.WantTemplate <@ fun (age : Nullable) -> age = %%(Expr.Value (Nullable 5)) @> + let withoutValue = + ParameterizerAssert.WantTemplate <@ fun (age : Nullable) -> age = %%(Expr.Value (Nullable())) @> + + let slot = + Assert.ContainsSingle (withValue.Slots, "The compiler writes no nullable as a value, so it is data.") + Assert.AreEqual(typeof>, slot.Variable.Type, "The slot should have the type of the node.") + Assert.AreEqual(5, valueOf 0 withValue.Values, "The slot should hold the value.") + + Assert.ContainsSingle (withoutValue.Slots, "A nullable without a value is data as well, and no null literal.") + |> ignore + + Assert.IsNull (valueOf 0 withoutValue.Values, "The slot should hold no value.") + + // The value of a nullable floating-point number is a finite double, which a literal can be, so the type of the + // node decides here as well. + let ofRate = + ParameterizerAssert.WantTemplate <@ fun (rate : Nullable) -> rate = %%(Expr.Value (Nullable 2.5)) @> + + Assert.ContainsSingle (ofRate.Slots, "A nullable floating-point number is data, whatever its value is.") + |> ignore + + Assert.AreEqual(2.5, valueOf 0 ofRate.Values, "The slot should hold the value.") + + [] + member _.``A case of a union that is null must be a slot when code put it into a quotation as a value`` () = + // The compiler writes a case of a union as a case, also the one that is represented by null. As a value such a + // null can only come from code, and how it is written into a query is a matter of the union. + let ofUnion = + ParameterizerAssert.WantTemplate <@ fun (rank : Rank) -> rank = %%(Expr.Value (null, typeof)) @> + + let ofOption = + ParameterizerAssert.WantTemplate + <@ fun (nick : string option) -> nick = %%(Expr.Value (null, typeof)) @> + + let ofText = + ParameterizerAssert.WantTemplate <@ fun (name : string | null) -> name = %%(Expr.Value (null, typeof)) @> + + let slot = + Assert.ContainsSingle (ofUnion.Slots, "The null of a union type is a case of the union, so it is data.") + Assert.AreEqual(typeof, slot.Variable.Type, "The slot should have the type of the union.") + Assert.IsNull (valueOf 0 ofUnion.Values, "The slot should hold the case, which is null.") + + Assert.ContainsSingle (ofOption.Slots, "An option is such a union, and its None is data as well.") + |> ignore + + Assert.IsEmpty (ofText.Slots, "The compiler writes the null of a text as a value, so that one is a literal.") + + [] + member _.``A function with a definition that is called twice must have the slots of each call`` () = + // The function binds a number, reads it and reads ten times the number: two values that a call computes. + let template = + ParameterizerAssert.WantTemplate + <@ + fun (p : Person) -> + Conditions.isWithinProcessors p + || not (Conditions.isWithinProcessors p) + @> + + Assert.HasCount ( + 4, + template.Slots, + "Each call computes its values for itself, so the second call should not have the slots of the first." + ) + + // Values that the quotation builds + + [] + member _.``A value that the quotation builds must stay what it is, with its parts as slots`` + (quotation : Expr, slots : Type array) + = + let template = ParameterizerAssert.WantTemplate quotation + + CollectionAssert.AreEqual ( + slots, + template.Slots |> Seq.map _.Variable.Type |> Seq.toArray, + "The captured parts should be the slots, and the value that is built of them no slot of its own." + ) + + // The functions of Query + + [] + member _.``Query.parameter must make a literal a slot`` () = + let template = ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > Query.parameter 18 @> + let other = ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > Query.parameter 21 @> + let literal = ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > 18 @> + + let slot = Assert.ContainsSingle (template.Slots, "The literal should be a parameter.") + Assert.AreEqual(ValueNone, slot.Name, "A literal has no variable to be named after.") + Assert.AreEqual(18, valueOf 0 template.Values, "The slot should hold the literal.") + Assert.AreEqual(template.Key, other.Key, "Another value of the parameter is the same query text.") + Assert.AreNotEqual(template.Key, literal.Key, "A parameter and a literal are different query texts.") + Assert.IsFalse (callsQuery template.Body, "The template should hold the variable of the slot, not the call.") + + [] + member _.``Query.parameter must leave a captured value the slot it is`` () = + let limit = 18 + let marked = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > Query.parameter limit || fst p.Scores > limit @> + let plain = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > limit || fst p.Scores > limit @> + + CollectionAssert.AreEqual ( + [| ValueSome "limit"; ValueSome "limit" |], + marked.Slots |> Seq.map _.Name |> Seq.toArray, + "The marked use should be a slot with the name of the variable, like the plain use." + ) + + Assert.AreEqual(plain.Key, marked.Key, "Saying what a captured value already is changes nothing.") + + [] + member _.``Query.parameter must compute its argument`` () = + let name = "bob" + let shape = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Name = Query.parameter (name.ToUpperInvariant ()) @> + + Assert.ContainsSingle (shape.Values, "The argument reads nothing of the document, so it is one slot.") + |> ignore + + Assert.AreEqual("BOB", valueOf 0 shape.Values, "The slot should hold what the argument computes.") + + [] + member _.``Query.constant must make a captured value a part of the key`` () = + let templateOf (limit : int) = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > Query.constant limit @> + let template = templateOf 18 + let literal = NormalizerAssert.WantNormal <@ fun (p : Person) -> p.Age > 18 @> + + Assert.IsEmpty (template.Slots, "A constant is no parameter.") + + Assert.AreEqual( + (ParameterizerAssert.WantShape literal).Key, + template.Key, + "The constant should be in the key as the literal with its value is." + ) + + Assert.AreNotEqual(template.Key, (templateOf 21).Key, "Another value of a constant is another query text.") + + NormalizerAssert.AreEquivalent + literal + template.Body + "The template should hold the value where the call was, as if the literal had been written." + + [] + member _.``Query.constant must compute its argument`` () = + let limit = 18 + let computed = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > Query.constant (limit + 1) @> + let literal = ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > 19 @> + + Assert.IsEmpty (computed.Values, "A constant is no parameter.") + Assert.AreEqual(literal.Key, computed.Key, "The key should hold what the argument computes.") + + // Choices + + [] + member _.``A branch that is not taken must not be computed`` () = + let shapeOf (filter : string option) = + ParameterizerAssert.WantShape <@ fun (p : Person) -> filter.IsNone || p.Name = filter.Value.Trim () @> + + let without = shapeOf None + let withFilter = shapeOf (Some " Bob ") + + CollectionAssert.AreEqual ( + [| ValueSome (box true); ValueNone |], + without.Values |> Seq.toArray, + "Without a filter nothing is trimmed: the code would raise, as it would in the compiled function." + ) + + CollectionAssert.AreEqual ( + [| ValueSome (box false); ValueSome (box "Bob") |], + withFilter.Values |> Seq.toArray, + "With a filter the branch is taken and its part is computed." + ) + + Assert.AreEqual(without.Key, withFilter.Key, "The key should hold both branches, whichever is taken.") + + [] + member _.``The other branch of a choice must not be computed when the first one is taken`` () = + let flag = true + let filter : string option = None + let limit = 18 + + let shape = + ParameterizerAssert.WantShape <@ fun (p : Person) -> if flag then p.Age > limit else p.Name = filter.Value @> + + CollectionAssert.AreEqual ( + [| ValueSome (box true); ValueSome (box 18); ValueNone |], + shape.Values |> Seq.toArray, + "The branch that is taken has its value, the other one has none." + ) + + [] + member _.``A branch inside a branch that is not taken must not be computed`` () = + let flag = false + let filter : string option = None + + let shape = + ParameterizerAssert.WantShape <@ fun (p : Person) -> flag && (filter.Value.Length > 3 || p.Name = filter.Value) @> + + CollectionAssert.AreEqual ( + [| ValueSome (box false); ValueNone; ValueNone |], + shape.Values |> Seq.toArray, + "Nothing under a branch that is not taken is computed, whatever its own conditions are." + ) + + [] + member _.``A condition that is one slot at two places must decide its branch at each of them`` () = + let flag = false + let filter : string option = None + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let enabled = flag + (enabled && p.Name = filter.Value) + || (enabled && p.Name = filter.Value.Trim ()) + @> + + CollectionAssert.AreEqual ( + [| ValueSome (box false); ValueNone; ValueNone |], + shape.Values |> Seq.toArray, + "The slot of the flag is found again at the second place, and there too it should keep its branch from being computed." + ) + + [] + member _.``A condition that Query.constant makes a constant must decide its branch`` () = + let shapeOf (flag : bool) (filter : string option) = + ParameterizerAssert.WantShape <@ fun (p : Person) -> Query.constant flag || p.Name = filter.Value.Trim () @> + + CollectionAssert.AreEqual ( + [| (ValueNone : objnull voption) |], + (shapeOf true None).Values |> Seq.toArray, + "The constant is true, so the other branch is not taken and nothing of it is computed." + ) + + CollectionAssert.AreEqual ( + [| ValueSome (box "Bob") |], + (shapeOf false (Some " Bob ")).Values |> Seq.toArray, + "The constant is false, so the other branch is taken and its part is computed." + ) + + [] + member _.``A condition that is the default value of a boolean must leave no branch to compute`` () = + let filter : string option = None + let shape = + ParameterizerAssert.WantShape <@ fun (p : Person) -> bool () && p.Name = filter.Value.Trim () @> + + Assert.IsEmpty ( + shape.Values, + "The condition is false in the quotation itself, so its branch is gone from the normal form and nothing of it is computed." + ) + + [] + member _.``A choice by the document must have both its branches computed`` () = + let limit = 18 + + let shape = + ParameterizerAssert.WantShape <@ fun (p : Person) -> if p.Active then p.Age > limit + 1 else p.Age > limit + 2 @> + + CollectionAssert.AreEqual ( + [| ValueSome (box 19); ValueSome (box 20) |], + shape.Values |> Seq.toArray, + "Which branch is taken is known only for a document, so the query needs the values of both." + ) + + [] + member _.``A part of a branch that is not taken must be computed when it is used outside the branch too`` () = + let flag = false + let meter = Meter () + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let name = meter.Read "Bob" + (flag && p.Name = name) || p.Nick = Some name + @> + + CollectionAssert.AreEqual ( + [| ValueSome (box false); ValueSome (box "Bob") |], + shape.Values |> Seq.toArray, + "The second use is in a branch that is taken, so the slot of both uses needs its value." + ) + + Assert.AreEqual(1, meter.Readings, "The code of the value should run once.") + + [] + member _.``Query.constant must be computed in a branch that is not taken`` () = + let meter = Meter () + let keyOf (flag : bool) = + (ParameterizerAssert.WantShape <@ fun (p : Person) -> flag || p.Age > Query.constant (meter.Read 18) @>).Key + + let taken = keyOf false + let readings = meter.Readings + let notTaken = keyOf true + + Assert.AreEqual(taken, notTaken, "A constant is a part of the key, so the key needs it in either case.") + Assert.AreEqual(readings + 1, meter.Readings, "The constant should be computed although its branch is not taken.") + + // The key + + [] + member _.``The key must list the nodes of the quotation, every node before the nodes under it`` () = + let limit = 18 + let quotation = <@ fun (p : Person) -> p.Age > limit || p.Name = "Bob" @> + let shape = ParameterizerAssert.WantShape quotation + + let struct (greaterThan, age, equals, name) = + match quotation with + | Lambda (_, + IfThenElse (Call (None, greaterThan, [ PropertyGet (_, age, _); _ ]), + _, + Call (None, equals, [ PropertyGet (_, name, _); _ ]))) -> + struct (greaterThan, age, equals, name) + | other -> invalidOp $"The quotation is not the two comparisons it was written as: %A{other}" + + let token (kind : ShapeTokenKind) (number : int) (subject : objnull) (detail : objnull) : ShapeToken = { + Kind = kind + Number = number + Subject = subject + Detail = detail + } + + CollectionAssert.AreEqual ( + [| + token ShapeTokenKind.Lambda 0 typeof null + token ShapeTokenKind.IfThenElse 0 null null + token ShapeTokenKind.Call 0 greaterThan null + token ShapeTokenKind.PropertyGet 0 age null + token ShapeTokenKind.Variable 0 null null + token ShapeTokenKind.Slot 0 typeof "limit" + token ShapeTokenKind.Constant 0 typeof true + token ShapeTokenKind.Call 0 equals null + token ShapeTokenKind.PropertyGet 0 name null + token ShapeTokenKind.Variable 0 null null + token ShapeTokenKind.Constant 0 typeof "Bob" + |], + shape.Key.Tokens |> Seq.toArray, + "The key should hold the function, the choice that `||` is, and each comparison with what it compares." + ) + + Assert.HasCount ( + shape.Key.Tokens.Length, + (string shape.Key).Split('\n', StringSplitOptions.RemoveEmptyEntries), + "The key should be written with one token on a line." + ) + + [] + member _.``Two keys with one hash code must be told apart by their tokens`` () = + let keyOf (token : ShapeToken) : ShapeKey = { + Tokens = System.Collections.Immutable.ImmutableArray.Create token + Hash = 1 + } + + let token : ShapeToken = { + Kind = ShapeTokenKind.Constant + Number = 0 + Subject = typeof + Detail = 18 + } + + Assert.AreEqual(keyOf token, keyOf token, "Keys with equal tokens are equal, whichever arrays hold the tokens.") + + // A hash code is only the first thing two keys are compared by: after it, everything a token says counts. + Assert.AreNotEqual( + keyOf token, + keyOf { token with Kind = ShapeTokenKind.Slot }, + "Tokens of different kinds are different tokens." + ) + + Assert.AreNotEqual(keyOf token, keyOf { token with Number = 1 }, "The number of a token is a part of it.") + + Assert.AreNotEqual( + keyOf token, + keyOf { token with Subject = typeof }, + "The subject of a token is a part of it." + ) + + Assert.AreNotEqual(keyOf token, keyOf { token with Detail = 21 }, "The detail of a token is a part of it.") + + [] + member _.``A variable must be in the key as the distance to its binding`` () = + let keyOf (expr : Expr) = (ParameterizerAssert.WantShape expr).Key + let outer = keyOf <@ fun (first : int) (second : int) -> first @> + let inner = keyOf <@ fun (first : int) (second : int) -> second @> + let renamed = keyOf <@ fun (a : int) (b : int) -> a @> + + Assert.AreNotEqual(outer, inner, "Functions that return different variables are different functions.") + Assert.AreEqual(outer, renamed, "The names of the variables are not in the key.") + + [] + member _.``A struct tuple and a reference tuple must have different keys`` () = + let keyOf (expr : Expr) = (ParameterizerAssert.WantShape expr).Key + + Assert.AreNotEqual( + keyOf <@ fun (p : Person) -> (p.Name, p.Age) @>, + keyOf <@ fun (p : Person) -> struct (p.Name, p.Age) @>, + "The two kinds of tuples can be written into a document in different ways, so they are different queries." + ) + + [] + member _.``A variable of a delegate must be in the key as the distance to its binding`` () = + let keyOf (expr : Expr) = (ParameterizerAssert.WantShape expr).Key + let first = keyOf <@ Func(fun first second -> first) @> + let second = keyOf <@ Func(fun first second -> second) @> + let renamed = keyOf <@ Func(fun a b -> a) @> + + Assert.AreNotEqual(first, second, "Delegates that return different variables are different delegates.") + Assert.AreEqual(first, renamed, "The names of the variables are not in the key.") + + [] + member _.``A captured value inside a delegate must be a slot`` () = + let name = "vip" + + let template = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> Enumerable.Any (p.Tags, (fun tag -> tag = name)) @> + + let slot = Assert.ContainsSingle (template.Slots, "The delegate captures one value.") + Assert.AreEqual(ValueSome "name", slot.Name, "The slot should have the name of the variable.") + + CollectionAssert.AreEqual ( + [| slot.Variable |], + template.Body.GetFreeVars () |> Seq.toArray, + "The delegate should be built anew around the variable of the slot." + ) + + [] + member _.``A key that no code has filled must be equal to itself and hold no token`` () = + let empty = Unchecked.defaultof + + Assert.AreEqual(empty, Unchecked.defaultof, "A key without tokens is a key like any other.") + Assert.AreEqual("", string empty, "It should be written as no tokens, not fail.") + + [] + member _.``A quotation without slots must be its own template`` () = + let normal = NormalizerAssert.WantNormal <@ fun (p : Person) -> p.Age > 18 @> + let template = + Assert.WantOk (Parameterizer.templateOf normal, "A quotation of literals has a template.") + + Assert.AreSame(normal, template.Body, "Nothing is replaced, so no node should be built.") + + // Errors + + [] + member _.``A function value in the place of a value of the query must be reported`` (quotation : Expr) = + let error = ParameterizerAssert.WantError quotation + + Assert.AreEqual( + TranslationErrorCode.CapturedFunctionValue, + error.Code, + "A compiled function can be neither read nor passed as a parameter." + ) + + Assert.IsNotEmpty (error.Hints, "The error should say what to write instead.") + Assert.IsValueSome (error.Location, "The function was passed in this file, so the error has its place.") + + [] + member _.``A value that is no literal must not be made a constant`` (quotation : Expr) = + let error = ParameterizerAssert.WantError quotation + + Assert.AreEqual( + TranslationErrorCode.Unsupported, + error.Code, + "The key holds a constant, and only a literal says by its equality what a query writes for it." + ) + + Assert.Contains ( + "Query.constant", + error.Message, + StringComparison.Ordinal, + "The message should name the function that was given the value." + ) + + Assert.Contains ( + "the null of a reference type that is no union of F#, as an option is", + error.Message, + StringComparison.Ordinal, + "The message should not call a case of a union that is null a literal: it is the null of a reference type, and two of these rows." + ) + + Assert.IsNotEmpty (error.Hints, "The error should say what to write instead.") + Assert.IsValueSome (error.Location, "The call was written in this file, so the error has its place.") + + [] + member _.``Code that raises an exception must be reported with the exception as the cause`` () = + let zero = 0 + let error = ParameterizerAssert.WantError <@ fun (p : Person) -> p.Age > 10 / zero @> + + Assert.AreEqual( + TranslationErrorCode.ClientEvaluationFailed, + error.Code, + "The part has to be computed, and computing it failed." + ) + + let cause = Assert.WantValueSome (error.Cause, "The error should carry the exception.") + Assert.IsInstanceOfType (cause, typeof, "The cause should be the exception of the division.") + + [] + member _.``Query.constant of code that raises an exception must be reported`` () = + let zero = 0 + let error = ParameterizerAssert.WantError <@ fun (p : Person) -> p.Age > Query.constant (10 / zero) @> + + Assert.AreEqual( + TranslationErrorCode.ClientEvaluationFailed, + error.Code, + "The constant has to be computed, and computing it failed." + ) + + [] + [] + [] + member _.``A function of Query over a value of the document must be reported`` (isConstant : bool) = + let struct (name, quotation) = + if isConstant then + struct ("Query.constant", <@@ fun (p : Person) -> p.Age > Query.constant p.Age @@>) + else + struct ("Query.parameter", <@@ fun (p : Person) -> p.Age > Query.parameter p.Age @@>) + + let error = ParameterizerAssert.WantError quotation + + Assert.AreEqual( + TranslationErrorCode.Unsupported, + error.Code, + "A value of the document is not known before the query runs." + ) + + Assert.Contains (name, error.Message, StringComparison.Ordinal, "The message should name the function.") + Assert.IsNotEmpty (error.Hints, "The error should say what to write instead.") + + [] + member _.``A variable that nothing binds must be reported`` () = + let stray = Var ("stray", typeof) + let quotation = <@ fun (p : Person) -> p.Age > %%(Expr.Var stray) @> + let error = ParameterizerAssert.WantError quotation + + Assert.AreEqual(TranslationErrorCode.Unsupported, error.Code, "The variable has no value.") + Assert.Contains ("stray", error.Message, StringComparison.Ordinal, "The message should name the variable.") + + [] + member _.``A quotation inside the quotation must be reported`` () = + let person = Var ("p", typeof) + let quotation = Expr.Lambda (person, Expr.QuoteTyped <@@ 1 @@>) + + let error = + Assert.WantError (Parameterizer.shapeOf quotation, "A quotation is neither a value nor an operation on the document.") + + Assert.AreEqual(TranslationErrorCode.Unsupported, error.Code, "A query cannot express it.") diff --git a/tests/Cosmos.Quotations.Tests/QuotationAssert.fs b/tests/Cosmos.Quotations.Tests/QuotationAssert.fs index b8a348bf..43925f8b 100644 --- a/tests/Cosmos.Quotations.Tests/QuotationAssert.fs +++ b/tests/Cosmos.Quotations.Tests/QuotationAssert.fs @@ -10,7 +10,11 @@ open FSharp.Quotations.Patterns open Swensen.Unquote +// The functions of FSharp.Core that give an option or reference tuples are shadowed there. So are the cases of a +// result, by the results of the item operations, which is why a result is matched with its full case names here. +open FSharp.Azure.Cosmos open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests /// Questions about a quotation that the assertions and the tests ask. [] @@ -121,8 +125,8 @@ module NormalizerAssert = /// let WantNormal (expr : Expr) : Expr = match Normalizer.normalize expr with - | Ok normal -> normal - | Error error -> + | Result.Ok normal -> normal + | Result.Error error -> raise ( AssertFailedException $"The quotation should have a normal form, but: %s{error.Message}\n%s{error.Fragment}\n%A{expr}" @@ -133,8 +137,9 @@ module NormalizerAssert = /// let WantError (expr : Expr) : TranslationError = match Normalizer.normalize expr with - | Ok normal -> raise (AssertFailedException $"The quotation should be an error, but has the normal form\n%A{normal}") - | Error error -> error + | Result.Ok normal -> + raise (AssertFailedException $"The quotation should be an error, but has the normal form\n%A{normal}") + | Result.Error error -> error /// /// Asserts that and are the same quotation up to their bound @@ -175,3 +180,65 @@ module NormalizerAssert = evaluated input, $"The quotation should compute what the code computes for %A{input}.\n%A{quotation}" ) + +/// Questions about a template that the tests ask. +[] +module internal Templates = + + /// + /// The quotation of with the value of every slot at the place of its variable, which + /// is a quotation that can be evaluated again. A slot without a value gets the default value of its type: it is in + /// a branch that is not taken, so nothing reads it. + /// + let withValues (template : Template) : Expr = + template.Body.Substitute (fun variable -> + template.Slots + |> Seq.tryFindIndex (fun slot -> obj.ReferenceEquals (slot.Variable, variable)) + |> ValueOption.map (fun index -> + match template.Values[index] with + | ValueSome value -> Expr.Value (value, variable.Type) + | ValueNone -> Expr.DefaultValue variable.Type + ) + // The substitution of FSharp.Core takes an option. + |> ValueOption.toOption + ) + +/// Assertions on what the parameterizer makes of a quotation. +[] +module internal ParameterizerAssert = + + /// + /// The shape of the normal form of ; fails when the parameterizer reports an error. + /// + let WantShape (expr : Expr) : Shape = + Assert.WantOk ( + expr |> NormalizerAssert.WantNormal |> Parameterizer.shapeOf, + $"The quotation should have a shape.\n%A{expr}" + ) + + /// + /// The template of the normal form of ; fails when the parameterizer reports an error. + /// + let WantTemplate (expr : Expr) : Template = + Assert.WantOk ( + expr + |> NormalizerAssert.WantNormal + |> Parameterizer.templateOf, + $"The quotation should have a template.\n%A{expr}" + ) + + /// + /// The error that the parameterizer reports for the normal form of ; fails when it gives a + /// result, and when it reports one error for the shape and another for the template. + /// + let WantError (expr : Expr) : TranslationError = + let normal = NormalizerAssert.WantNormal expr + let ofShape = + Assert.WantError (Parameterizer.shapeOf normal, $"The quotation should have no shape.\n%A{expr}") + + let ofTemplate = + Assert.WantError (Parameterizer.templateOf normal, $"The quotation should have no template.\n%A{expr}") + + Assert.AreEqual(ofShape.Code, ofTemplate.Code, "The shape and the template should fail alike.") + Assert.AreEqual(ofShape.Message, ofTemplate.Message, "The shape and the template should fail alike.") + ofShape diff --git a/tests/Cosmos.Quotations.Tests/TestCategories.fs b/tests/Cosmos.Quotations.Tests/TestCategories.fs index 62b6b86a..797d5ccb 100644 --- a/tests/Cosmos.Quotations.Tests/TestCategories.fs +++ b/tests/Cosmos.Quotations.Tests/TestCategories.fs @@ -26,3 +26,14 @@ type NormalizerUnitTestCategoryAttribute () = /// override _.TestCategories = [| "Unit"; "Normalizer" |] :> IList + +/// +/// Categorizes a unit test of the parameterizer, which tells the shape of a quotation from the values it was written +/// with: and +/// . +/// +type ParameterizerUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Parameterizer" |] :> IList From 88a451da493c5aa679342aa1b67476e785571273 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Mon, 12 Oct 2026 12:34:27 +0200 Subject: [PATCH 09/10] feat(quotations): describe how the serializer writes a document A query has to read the property that the serializer wrote. A query that reads a property that is not there returns nothing, with no error to say why, so the translator asks a layout how the documents were written instead of guessing from the names of members. IJsonLayout gives the name of the property that holds a member of a document, and how an enumeration, a tuple, a collection, a map, a case of a union and a type with derived types are written. JsonLayout.ofSerializerOptions makes the layout of System.Text.Json with FSharp.SystemTextJson from the options of the serializer, and asks the serializer itself: the contract that the options resolve for a type names the converter that writes it, so the order of the converters, a converter named in an attribute and the naming policy count as they do when a document is written. The layout supports the set-ups that it has been compared with the serializer for, and refuses the others with one sentence for every setting that it does not support: unions with an external tag or no tag, references that are handled, numbers that are written as texts and read-only members that are left out. A type that it cannot describe is answered with "not described" and never with a guess: a type that a converter of the application writes, a record or a union with options of its own in the overrides or in an attribute, a union with a case that is null or a tag that is no text, and a type that a resolver of the application made a contract of. An enumeration is described by what the serializer writes for its values. It is asked for the values that have a name, for the smallest number that no name stands for and for a combination of two named values that has no name of its own, and they all have to come out as one kind of JSON value. A number contradicts no kind, because the converter of names writes a value without a name as its number, and a refusal of one of the two extra values contradicts nothing, because such a value is in no document. Optional values are not part of it. A query guards a member that can be without a value by testing both ways it can be missing, so how an option is written does not change the query. Co-Authored-By: Claude Sonnet 5.5 --- .github/copilot-instructions.md | 4 +- Directory.Packages.props | 1 + .../FSharp.Azure.Cosmos.Quotations.fsproj | 2 + src/Cosmos.Quotations/JsonLayout.fs | 1335 +++++++++++++++++ .../Cosmos.Quotations.Tests/TestCategories.fs | 10 + 5 files changed, 1351 insertions(+), 1 deletion(-) create mode 100644 src/Cosmos.Quotations/JsonLayout.fs diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index 0f41e6f5..a8733246 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -17,7 +17,8 @@ │ ├── Normalizer.fs – normal form of a quotation │ ├── Evaluator.fs – value of a part of a quotation that reads no variable │ ├── Query.fs – functions that say whether a value is a constant or a parameter of the query -│ └── Parameterizer.fs – shape of a quotation, by which its translation is found again, and the values of its parameters +│ ├── Parameterizer.fs – shape of a quotation, by which its translation is found again, and the values of its parameters +│ └── JsonLayout.fs – how the serializer writes a document: names of members, enumerations, tuples, collections, maps, unions and derived types ├── src/Cosmos/ – main library (FSharp.Azure.Cosmos) │ ├── SubStatusCodes.fs – documented Cosmos DB sub-status codes │ ├── Cosmos.fs – core types and container extensions @@ -46,6 +47,7 @@ * [`FSharp.Control.TaskSeq`](https://github.com/fsprojects/FSharp.Control.TaskSeq) – `IAsyncEnumerable` / `taskSeq` support * [`FSharp.Control.Reactive`](https://github.com/fsprojects/FSharp.Reactive) – Rx extensions for F# * [`FsToolkit.ErrorHandling`](https://github.com/demystifyfp/FsToolkit.ErrorHandling) – `taskResult`, `Result`, `voption` CEs +* [`FSharp.SystemTextJson`](https://github.com/Tarmil/FSharp.SystemTextJson) – F# types in `System.Text.Json`; `FSharp.Azure.Cosmos.Quotations` reads its options to know how documents are written * [`Unquote`](https://github.com/SwensenSoftware/unquote) – test assertions * [`MSTest`](https://github.com/microsoft/testfx) – test framework diff --git a/Directory.Packages.props b/Directory.Packages.props index 69f8e798..279a2585 100644 --- a/Directory.Packages.props +++ b/Directory.Packages.props @@ -8,6 +8,7 @@ + diff --git a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj index c907c6c6..f393e3e0 100644 --- a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj +++ b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj @@ -26,9 +26,11 @@ + + all runtime; build; native; contentfiles; analyzers; buildtransitive diff --git a/src/Cosmos.Quotations/JsonLayout.fs b/src/Cosmos.Quotations/JsonLayout.fs new file mode 100644 index 00000000..3172b95d --- /dev/null +++ b/src/Cosmos.Quotations/JsonLayout.fs @@ -0,0 +1,1335 @@ +namespace FSharp.Azure.Cosmos.Quotations + +open System +open System.Collections.Concurrent +open System.Collections.Generic +open System.Collections.Immutable +open System.Reflection +open System.Text.Json +open System.Text.Json.Serialization +open System.Text.Json.Serialization.Metadata +open FSharp.Reflection + +open FSharp.Azure.Cosmos + +/// +/// A member of a document as a query reads it: a property or a field, and the type of the value that it is read from. +/// +/// +/// The member alone does not tell that type. A quotation names an inherited property as the type that declares it +/// has it, also when the property is read from a value of a derived type, and the serializer can write the two types +/// in different ways: one as an object, the other by a converter. +/// +[] +type DocumentMember = { + /// The type of the value that the member is read from. In a quotation it is the type of the receiver. + Holder : Type + /// The property or the field, as any type that has it names it. + Member : MemberInfo +} + +/// +/// How a value of an enumeration is written. A query has to know it to compare such values by their order and to test +/// their bits, which only a number allows. +/// +/// +/// +/// The encoding is the kind of JSON value, and not what is written for one value of the enumeration: a naming policy +/// can spell a name, an attribute can declare one, and a converter of the application writes what it likes. So what +/// stands for such a value in a query has to come from the serializer: the encoding does not say it. +/// +/// +/// The layout learns the kind by asking the serializer to write the values that have a name, the smallest number that +/// no name stands for, and a combination of two named values that has no name of its own. An enumeration is described +/// when they all come out as one kind of JSON value, where a number is no contradiction to names: a converter of +/// names writes a value without a name as its number. A converter that writes some other value in a way of its own is +/// not noticed. +/// +/// +[] +type EnumEncoding = + /// As the number under the value. + | Number + /// + /// As a JSON string: the name of the value in the spelling that its converter gives it, or what a converter of the + /// application writes for it. The converter of System.Text.Json writes the names of the flags for a combination of + /// flags that it has names for, and the number for any other value that has no name, unless it was made to refuse + /// such a value. + /// + | String + /// + /// The layout does not describe how the values are written: neither as numbers nor as strings, some as numbers + /// and others as strings, a value that has no name as a string where the values with a name are numbers, or not + /// all of them because the converter refuses one. + /// + | NotDescribed + +/// +/// How a tuple is written. A query has to know it to read an item of a tuple that a document holds. +/// +[] +type TupleEncoding = + /// As a JSON array of the items in their order. A tuple of more than seven items is one array as well. + | Array + /// The layout does not describe how the tuple is written: a converter that it does not know writes it. + | NotDescribed + +/// +/// How a collection is written. A query has to know it to ask about the items of a collection that a document holds. +/// +[] +type CollectionEncoding = + /// + /// As a JSON array with an item for every item of the collection. + /// + /// The type of an item. + | Array of element : Type + /// + /// Not as an array of its items, or the layout does not know how: an array of bytes is written as one text, and a + /// converter that the layout does not know can write anything. + /// + | NotDescribed + +/// +/// How a map or a dictionary is written. A query has to know it to look a key up in a map that a document holds. +/// +[] +type MapEncoding = + /// + /// As a JSON object with a property for every key. + /// + /// The type of a key. + /// The type of a value. + | Object of key : Type * value : Type + /// + /// As a JSON array with an item for every key, which is an array of the key and its value. FSharp.SystemTextJson + /// writes a map this way when its keys are no texts. + /// + /// The type of a key. + /// The type of a value. + | ArrayOfPairs of key : Type * value : Type + /// The layout does not describe how the map is written: a converter that it does not know writes it. + | NotDescribed + +/// +/// A step from a JSON value to a value that it holds. The steps to a part of a union start at the value of the union. +/// +[] +type JsonStep = + /// + /// To the property of a JSON object that has this name. + /// + /// The name of the property. + | Property of name : string + /// + /// To the item of a JSON array at this index. + /// + /// The index of the item, counted from zero. + | Item of index : int + +/// +/// What tells that a value of a union is of one case. A query has to know it to ask for the values of a case. +/// +[] +type UnionCaseMark = + /// + /// The JSON value at the end of is the text . With no step the value + /// of the union itself is the tag, as for a case without fields that is written as its name alone. + /// + /// The steps from the value of the union to the tag. + /// The tag of the case. + | Tag of path : ImmutableArray * tag : string + /// + /// Nothing that is written tells the case: the union has one case, whose one field is written in place of the + /// union. + /// + | Unmarked + +/// +/// Where the value of a field of a union case is written. +/// +[] +type UnionFieldPlace = + /// + /// The value of the field is the JSON value at the end of . With no step it is written in + /// place of the union. + /// + /// The steps from the value of the union to the value of the field. + | Value of path : ImmutableArray + /// + /// The field is a record, and its members are properties of the JSON object at the end of + /// , which holds the tag of the case next to them: the object is more than the record. + /// + /// names the property of a member of the record. + /// + /// The steps from the value of the union to the object that holds the members. + | Members of path : ImmutableArray + +/// +/// How a value of one case of a union is written. A query has to know it to test the case of a union that a document +/// holds and to read a field of that case. +/// +[] +type UnionCaseEncoding = + /// + /// The case is written in the way that is described. + /// + /// What tells that a value is of this case. + /// Where the fields of the case are written, in the order of the fields. + | Written of mark : UnionCaseMark * fields : ImmutableArray + /// + /// The layout does not describe how the case is written: the serializer refuses the union, a converter that the + /// layout does not know writes it, or the union is written in a way that the layout does not support, such as one + /// whose tags are no texts. + /// + | NotDescribed + +/// +/// A type that a polymorphic type can be written as, with the discriminator that tells it. +/// +[] +type DerivedType = { + /// The derived type. + Type : Type + /// The text that is written as the discriminator of the type; none when the type is written without one. + Discriminator : string voption +} + +/// +/// How a type with derived types is written. A query has to know it to ask for the documents of one derived type. +/// +[] +type PolymorphismEncoding = + /// The type has no derived types that the serializer writes with a discriminator, or has no polymorphism at all. + | NotPolymorphic + /// + /// The serializer writes a derived type as an object with the discriminator of the type in a property. + /// + /// The name of the property. + /// The derived types that the type declares. + | Polymorphic of discriminatorProperty : string * derivedTypes : ImmutableArray + /// + /// The layout does not describe how the type is written: the serializer refuses it, or a discriminator is a number + /// and no text. + /// + | NotDescribed + +/// +/// What a query has to know about how documents were serialized. The translator asks it for every member that a +/// quotation reads, so that the query reads the property that the serializer wrote, and for every value that is no +/// JSON object by itself: an enumeration, a tuple, a collection, a map and a union are each written in more than one +/// way. +/// +/// +/// +/// gives the layout of System.Text.Json with FSharp.SystemTextJson, for the set-ups that it supports. A layout of +/// another serializer implements this interface. +/// +type IJsonLayout = + + /// + /// The name of the JSON property that holds , a property or a field of a type + /// that is written as a JSON object; no value when the documents hold no such property, as far as the layout can + /// tell. + /// + /// + /// + /// A member that the serializer never writes has a name all the same when the name is declared on it, with + /// : such a member stands for a property + /// that something else writes into the document, as a type discriminator or a computed property is. + /// + /// + /// A field of a union case has no name here. + /// + /// gives the place of every field of a case, which is not always a property. + /// + /// + abstract MemberName : memberOfDocument : DocumentMember -> string voption + + /// + /// How a value of the enumeration is written. + /// + /// + /// + /// This member and the three after it are asked alike. is the member that + /// holds the value, when it is a member of a type written as a JSON object: a member can name a converter of its + /// own, which writes its value and no other, and the layout does not describe what such a converter writes. A + /// field of a union case, an item of a collection and an item of a tuple have no such member. + /// + /// + /// The type that is asked about is the type of the member, or the type under an option, a value option or a + /// nullable that the member is. + /// + /// + /// A member that the serializer never writes is not described: something else writes its property, in a way of + /// its own. + /// + /// + /// The member that holds the value, when a member does. + /// The type of the value: an enumeration, or a nullable of one. + abstract EnumEncoding : memberOfDocument : DocumentMember voption * enumType : Type -> EnumEncoding + + /// + /// How a value of the tuple type is written. It is asked as + /// + /// is. + /// + /// The member that holds the tuple, when a member does. + /// The type of the tuple, a struct tuple or a reference tuple. + abstract TupleEncoding : memberOfDocument : DocumentMember voption * tupleType : Type -> TupleEncoding + + /// + /// How a value of is written, when it is a collection. It is asked as + /// + /// is. + /// + /// The member that holds the collection, when a member does. + /// The type of the collection. + abstract CollectionEncoding : memberOfDocument : DocumentMember voption * collectionType : Type -> CollectionEncoding + + /// + /// How a value of is written, when it is a map or a dictionary. It is asked as + /// + /// is. + /// + /// The member that holds the map, when a member does. + /// The type of the map. + abstract MapEncoding : memberOfDocument : DocumentMember voption * mapType : Type -> MapEncoding + + /// + /// How a value of the union case is written: what tells that a value is of the case, and + /// where its fields are. The union is the one that declares the case. It is asked as + /// + /// is. + /// + /// + /// A union is described as a whole: when the layout cannot describe one case, it describes none of the cases of + /// the union. + /// + /// The member that holds the union, when a member does. + /// The case. + abstract UnionCaseEncoding : memberOfDocument : DocumentMember voption * case : UnionCaseInfo -> UnionCaseEncoding + + /// + /// How the serializer writes a type that has derived types, with the attributes + /// and + /// . + /// + /// + /// This is what the contract of says. A derived type is written with its discriminator + /// when it is written as the base type, and without one when it is written as itself; which of the two a query + /// meets depends on how the application writes its items. + /// + /// The type that declares the derived types. + abstract Polymorphism : baseType : Type -> PolymorphismEncoding + +/// +/// The layouts of the serializers that comes with. +/// +[] +module JsonLayout = + + /// The members of a type whatever their accessibility: a record of the caller may be internal or private. + [] + let private AnyAccessibility = BindingFlags.Public ||| BindingFlags.NonPublic + + /// The assembly of FSharp.SystemTextJson, whose own converters are the ones whose way to write is known here. + let private fsharpSerializerAssembly = typeof.Assembly + + /// + /// Whether is one of the converters of FSharp.SystemTextJson for tuples. A + /// converter of the library is asked for a tuple only when it is such a one: it has a class for two, three and four + /// items of either kind of tuple and one for every other number. + /// + /// + /// The base class of those converters, + /// , is public, and so are the classes of + /// the library that are derived from it: a converter of an application can be derived from any of them and write a + /// tuple in a way of its own. So only a class of the assembly of the library itself is one of its converters. + /// + let private isTupleConverter (converterType : Type) : bool = converterType.Assembly.Equals fsharpSerializerAssembly + + /// + /// Whether is made of the generic type . + /// + let private isMadeOf (definition : Type) (valueType : Type) : bool = + valueType.IsGenericType + && Type.(=) (valueType.GetGenericTypeDefinition (), definition) + + /// + /// Whether carries an attribute of the type : a + /// type, or a property of a record, which a type cannot inherit it from. + /// + let private isMarked (attributeType : Type) (declaration : MemberInfo) : bool = declaration.IsDefined (attributeType, false) + + /// + /// The name that declares for itself, when it does: the first name of the + /// of FSharp.SystemTextJson, which that library + /// reads before the of System.Text.Json. + /// The attributes of the member itself count, and not those of a declaration that it overrides: the serializers + /// read them that way. + /// + /// Whether the type of the member is written by FSharp.SystemTextJson. + /// The member. + let private declaredNameOf (readsJsonName : bool) (memberOfDocument : MemberInfo) : string voption = + let ofJsonName = + if readsJsonName then + memberOfDocument.GetCustomAttributes false + // A name with a field is the name of a field of a union case, not of this member. The library + // declares the field as a string that is never null and leaves it null when none is given. + |> Seq.tryFind (fun attribute -> + match withNull attribute.Field with + | null -> true + | _ -> false + ) + |> ValueOption.map _.Name.AsString() + else + ValueNone + + ofJsonName + |> ValueOption.orElseWith (fun () -> + match memberOfDocument.GetCustomAttribute false with + | null -> ValueNone + | attribute -> ValueSome attribute.Name + ) + + /// + /// Whether and are one member, also when one of them was asked + /// for through a derived class. + /// + let private isSameMember (first : MemberInfo) (second : MemberInfo) : bool = + first.MetadataToken = second.MetadataToken + && first.Module.Equals second.Module + && Type.(=) (first.DeclaringType, second.DeclaringType) + + /// + /// Whether is the property as a derived class overrides + /// it. A quotation names a property that is overridden as the class that declares it first has it, and the + /// contract of the derived class lists the override. + /// + let private isOverrideOf (declared : MemberInfo) (candidate : MemberInfo) : bool = + match declared, candidate with + | (:? PropertyInfo as declared), (:? PropertyInfo as candidate) -> + match declared.GetMethod, candidate.GetMethod with + | null, _ + | _, null -> false + | declaredGetter, candidateGetter -> + isSameMember (declaredGetter.GetBaseDefinition ()) (candidateGetter.GetBaseDefinition ()) + | _ -> false + + /// + /// Whether a union type has a case that is represented by . FSharp.SystemTextJson writes + /// such a case as null before it looks at anything else, which the layout does not describe. + /// + let private hasNullCase (unionType : Type) : bool = + unionType.GetCustomAttributes (typeof, false) + |> Seq.cast + |> Seq.exists _.Flags.HasFlag(CompilationRepresentationFlags.UseNullAsTrueValue) + + /// + /// with what it has answered kept: a question is answered once, and every later asking + /// gets the answer that was found. + /// + /// + /// An answer of a layout is a fact of the options, and finding it out asks the serializer, which can run code of + /// the application: a converter factory, a modifier of a contract. + /// can run + /// its function more than once for a key that several threads ask for at a time, so what is kept for a question + /// is the answer as a , which is computed by one of them. + /// + let private remembered (answer : 'Question -> 'Answer) : 'Question -> 'Answer = + let answers = ConcurrentDictionary<'Question, Lazy<'Answer>>() + let create = Func<'Question, Lazy<'Answer>>(fun question -> lazy answer question) + fun question -> answers.GetOrAdd(question, create).Value + + /// + /// What FSharp.SystemTextJson reads from its options and from the options of the serializer when it writes the + /// fields of a record. + /// + [] + type private RecordOptions = { + /// The naming policy for a field that declares no name; none when names are written as they are. + NamingPolicy : JsonNamingPolicy | null + /// Whether the properties of a record that are not its fields are written too. + IncludesProperties : bool + } + + /// + /// What FSharp.SystemTextJson reads from its options and from the options of the serializer when it writes a + /// union. + /// + [] + type private UnionOptions = { + /// How unions are written. + Encoding : JsonUnionEncoding + /// The name of the property that holds the tag of a case. + TagName : string + /// The name of the property that holds the fields of a case. + FieldsName : string + /// The naming policy for a case that declares no name; none when names are written as they are. + TagNamingPolicy : JsonNamingPolicy | null + /// The naming policy for a field of a case; none when names are written as they are. + FieldNamingPolicy : JsonNamingPolicy | null + } + + /// + /// The bits of that choose where the tag is. + /// + [] + let private UnionFormatBits = 0xFE + + /// + /// as spells it; as it is without a policy. + /// + let private spelled (policy : JsonNamingPolicy | null) (name : string) : string = + match policy with + | null -> name + | policy -> policy.ConvertName name + + /// + /// The tag that FSharp.SystemTextJson writes for a case: the first name of the + /// of the case, then the name of its + /// , then the name of the case as + /// spells it. A name that is declared is written as it is. No value for a name that is + /// a number or a boolean. A case that names one of its fields is refused together with its union, so no tag is + /// needed of such a case. + /// + let private unionTagOf (policy : JsonNamingPolicy | null) (case : UnionCaseInfo) : string voption = + let declared = + case.GetCustomAttributes typeof + |> Seq.cast + |> Seq.tryHead + + match declared with + | ValueSome attribute -> + match attribute.Name with + | JsonName.String text -> ValueSome text + | JsonName.Int _ + | JsonName.Bool _ -> ValueNone + | ValueNone -> + match + case.GetCustomAttributes typeof + |> Seq.cast + |> Seq.tryHead + with + | ValueSome attribute -> ValueSome attribute.Name + | ValueNone -> ValueSome (spelled policy case.Name) + + /// + /// Whether a case declares the name of one of its fields, with a + /// that has a field. + /// + let private declaresFieldNames (case : UnionCaseInfo) : bool = + case.GetCustomAttributes typeof + |> Seq.cast + |> Seq.exists (fun attribute -> + match withNull attribute.Field with + | null -> false + | _ -> true + ) + + /// + /// The names that FSharp.SystemTextJson writes the fields of a case under when it writes them as properties, in + /// the order of the fields: the name that F# gives a field, as the policy spells it. + /// + let private unionFieldNamesOf (options : UnionOptions) (case : UnionCaseInfo) : string array = + case.GetFields () + |> Array.map (fun field -> spelled options.FieldNamingPolicy field.Name) + + /// + /// Who writes the members of a type, which decides the rules that their names follow. + /// + [] + type private Writer = + /// System.Text.Json writes the type as an object, and its contract lists the properties. + | Serializer of JsonTypeInfo + /// FSharp.SystemTextJson writes the type as a record, with the common options. + | Record of RecordOptions + /// A converter that the layout does not know writes the type, or the type is not written as an object. + | Unknown + + /// + /// Whether FSharp.SystemTextJson writes a member of a record: its fields, whatever their accessibility, and of its + /// other properties the public ones, when the options or the member say so. It never writes a member that is marked + /// with , whatever the condition of the attribute + /// says. + /// + let private isWrittenByRecord (recordOptions : RecordOptions) (memberOfDocument : MemberInfo) : bool = + match memberOfDocument with + | :? PropertyInfo as property when not (isMarked typeof property) -> + let isField = + match property.DeclaringType with + | null -> false + | recordType -> + FSharpType.GetRecordFields (recordType, AnyAccessibility) + |> Array.exists (fun field -> isSameMember field property) + + let isPublic = + match property.GetMethod with + | null -> false + | getter -> getter.IsPublic + + isField + || (isPublic + && (recordOptions.IncludesProperties + || isMarked typeof property)) + | _ -> false + + /// + /// The name that FSharp.SystemTextJson writes a member of a record under: the name that the member declares, and + /// the name of the member as the naming policy spells it when it declares none. A member that is never written has + /// the name that it declares, when it declares one: it stands for a property that something else writes. + /// + let private recordMemberNameOf (recordOptions : RecordOptions) (memberOfDocument : MemberInfo) : string voption = + let declared = declaredNameOf true memberOfDocument + + if isWrittenByRecord recordOptions memberOfDocument then + declared + |> ValueOption.orElseWith (fun () -> ValueSome (spelled recordOptions.NamingPolicy memberOfDocument.Name)) + else + declared + + /// + /// The names that FSharp.SystemTextJson writes the members of a record under, one for each member that it writes. + /// + let private writtenNamesOfRecord (recordOptions : RecordOptions) (recordType : Type) : string array = + recordType.GetProperties (BindingFlags.Instance ||| AnyAccessibility) + |> Array.where (isWrittenByRecord recordOptions) + // A member that is written has a name: it declares one or the policy spells one. + |> Array.map (fun written -> (recordMemberNameOf recordOptions written).Value) + + /// + /// Whether no two of are one text. A document tells properties apart by their exact + /// characters, and so it tells the tags of a union. + /// + let private areDistinct (names : string seq) : bool = + let seen = HashSet StringComparer.Ordinal + names |> Seq.forall seen.Add + + /// How many constants of an enumeration, from the first on, are tried as the parts of a combination. A combination + /// needs two of them, and an enumeration that has a pair whose combination is no constant has one among its first + /// constants in all but the most unusual cases. The bound keeps an enumeration of thousands of codes from being + /// searched pair by pair. + let private CombinedConstants = 8 + + /// The smallest number from zero up that is no constant of an enumeration, as a value of it: a value that a + /// converter of names has no name for. Nothing when every number under the enumeration is a constant. + let private undeclaredValueOf (enumType : Type) (constants : obj array) : obj seq = + // Of one more number than there are constants, at least one is no constant. + seq { 0 .. constants.Length } + |> Seq.map (fun number -> Enum.ToObject (enumType, number)) + |> Seq.where (fun value -> not (Enum.IsDefined (enumType, value))) + |> Seq.truncate 1 + + /// The combination of two of the first constants of an enumeration that is no constant itself, as a value of the + /// enumeration: a converter of flags writes it as the names of the flags, and a converter of another kind writes + /// it by a rule of its own. Nothing when there is no such pair. + let private combinationOf (enumType : Type) (constants : obj array) : obj seq = + let candidates = constants |> Array.truncate CombinedConstants + + seq { + for first in 0 .. candidates.Length - 1 do + for second in first + 1 .. candidates.Length - 1 do + Enum.Parse (enumType, $"{candidates[first]}, {candidates[second]}") + } + |> Seq.where (fun value -> not (Enum.IsDefined (enumType, value))) + |> Seq.truncate 1 + + /// + /// The settings of the options that the layout cannot describe documents with, one sentence for each; none when + /// the layout supports the options. + /// + /// + /// A set-up that is not listed here is one that the layout has not been compared with the serializer for. The + /// converters of the application that stand among the options are no reason to refuse: a type that one of them + /// writes is not described, and the layout says so when it is asked about the type. + /// + let private refusalsOf (options : JsonSerializerOptions) : ImmutableArray = + let reasons = ImmutableArray.CreateBuilder() + + let factories = + options.Converters + |> Seq.where (fun converter -> converter :? JsonFSharpConverter) + |> Seq.cast + |> Seq.toArray + + match factories with + | [||] -> + reasons.Add + "FSharp.SystemTextJson is not among the converters of the options, and it writes the records, unions, tuples and options of F#." + | [| factory |] -> + if not (Type.(=) (factory.GetType (), typeof)) then + reasons.Add + "The converter of FSharp.SystemTextJson is of a class that an application derived from it, which can make converters with options that it does not show." + + let common = factory.Options + let encoding = common.UnionEncoding + + if not (common.Types.HasFlag JsonFSharpTypes.All) then + reasons.Add "FSharp.SystemTextJson has to write every kind of type of F#: its options say JsonFSharpTypes.All." + + if not (encoding.HasFlag JsonUnionEncoding.UnwrapOption) then + reasons.Add + "UnwrapOption is not set, so an option is written as a union with the name of its case, and not as its value." + + match int encoding &&& UnionFormatBits with + | 0 + | 4 -> () + | _ -> + reasons.Add + "Only AdjacentTag and InternalTag are supported places for the tag of a union: ExternalTag and Untagged are not." + + if encoding.HasFlag JsonUnionEncoding.UnwrapSingleFieldCases then + reasons.Add "UnwrapSingleFieldCases is set, which the layout does not support." + + if encoding.HasFlag JsonUnionEncoding.UnionFieldNamesFromTypes then + reasons.Add "UnionFieldNamesFromTypes is set, which the layout does not support." + + if + int encoding &&& UnionFormatBits = 0 + && String.Equals (common.UnionTagName, common.UnionFieldsName, StringComparison.Ordinal) + then + reasons.Add + $"The tag and the fields of a union are written under one name, %s{common.UnionTagName}: the later property hides the tag." + | _ -> + reasons.Add + "More than one converter of FSharp.SystemTextJson is among the converters of the options, and the layout reads the options of one." + + if not (isNull options.ReferenceHandler) then + reasons.Add "The options handle references, which adds the properties $id and $ref to documents." + + if options.NumberHandling.HasFlag JsonNumberHandling.WriteAsString then + reasons.Add "The options write numbers as texts." + + if options.IgnoreReadOnlyProperties then + reasons.Add "The options ignore read-only properties." + + if options.IgnoreReadOnlyFields then + reasons.Add "The options ignore read-only fields." + + reasons.ToImmutable () + + /// + /// The layout of what System.Text.Json writes with the options it is made of, with the converter of + /// FSharp.SystemTextJson among them. + /// + /// + /// The layout asks the serializer itself who writes a type: the contract that the options resolve for a type names + /// the converter. So the order of the converters, the kinds of types that FSharp.SystemTextJson is set to handle + /// and a converter that a type names in an attribute all count as they do when a document is written. + /// + [] + type private SerializerLayout (options : JsonSerializerOptions) = + + // A copy, so that the options of the caller stay as they are: the contract can be asked only from options + // that have a resolver and that are not changed any more. The resolver is the one of the caller, because a + // resolver cannot be copied: it can be any object. So the layout asks who the serializer asks, and a resolver + // of System.Text.Json takes no change after either has asked it, which keeps the two from disagreeing. + let contract = + let copy = + match options.TypeInfoResolver with + | null -> JsonSerializerOptions (options, TypeInfoResolver = DefaultJsonTypeInfoResolver ()) + | _ -> JsonSerializerOptions options + + copy.MakeReadOnly () + copy + + /// The contract of a type; none for a type that the serializer refuses. + let typeInfoOf (documentType : Type) : JsonTypeInfo voption = + try + ValueSome (contract.GetTypeInfo documentType) + with + | :? NotSupportedException + | :? InvalidOperationException + | :? ArgumentException + // FSharp.SystemTextJson makes its converters by reflection, so what one of them refuses a type with comes + // wrapped in this one: a union with a case that has two attributes with names is refused that way. + | :? TargetInvocationException -> ValueNone + + /// + /// The options that FSharp.SystemTextJson writes a record or a union type with, when they are the common ones: + /// the options of the converter that takes the type, which is the first one among the options that does, as + /// the serializer chooses it. No value when the type has options of its own, in the overrides or in an + /// attribute that the options allow, or when another converter writes it: such a type is not described. + /// + let commonOptionsOf (valueType : Type) : JsonFSharpOptions voption = + let hasOptionsOfItsOwn (common : JsonFSharpOptions) = + let isOverridden = + // The library declares the overrides as never null and gives null when there are none. + match withNull (common.Overrides common) with + | null -> false + | overrides -> + overrides.ContainsKey valueType + || (valueType.IsGenericType + && overrides.ContainsKey (valueType.GetGenericTypeDefinition ())) + + isOverridden + || (common.AllowOverride + && isMarked typeof valueType) + + match contract.Converters |> Seq.tryFind _.CanConvert(valueType) with + // The one factory of FSharp.SystemTextJson among the options, of that class itself: the options are refused + // when a class that an application derives from it stands among them, because such a class can make the + // converter of a record with other options than the ones it shows. + | ValueSome (:? JsonFSharpConverter as factory) -> + let common = factory.Options + + if hasOptionsOfItsOwn common then + ValueNone + else + ValueSome common + | _ -> ValueNone + + /// What FSharp.SystemTextJson reads when it writes a union type, when it writes it with the common options. + let unionOptionsOf (unionType : Type) : UnionOptions voption = + commonOptionsOf unionType + |> ValueOption.map (fun common -> { + Encoding = common.UnionEncoding + TagName = common.UnionTagName + FieldsName = common.UnionFieldsName + TagNamingPolicy = common.UnionTagNamingPolicy + FieldNamingPolicy = + match withNull common.UnionFieldNamingPolicy with + | null -> contract.PropertyNamingPolicy + | policy -> policy + }) + + /// + /// Whether the serializer made a contract itself. It chooses the converter by rules that the layout follows: the + /// first one among the options that takes the type, then the one that an attribute names, then one of its own. + /// A resolver of the application can make a contract from any converter instead, also from a converter of + /// FSharp.SystemTextJson that it made with options of its own, and nothing shows how it made that converter. + /// + /// + /// names the resolver + /// that made a contract. The resolver of the serializer names itself, also as the class that an application + /// derives from it to change the contracts it makes, while a contract that an application makes from a + /// converter names none. + /// + let isMadeBySerializer (info : JsonTypeInfo) : bool = + match info.OriginatingResolver with + | :? DefaultJsonTypeInfoResolver -> true + | _ -> false + + /// Who writes the members of a type. + let writerOf = + remembered (fun (documentType : Type) -> + match typeInfoOf documentType with + | ValueSome info when info.Kind = JsonTypeInfoKind.Object -> Writer.Serializer info + | ValueSome info when + isMadeBySerializer info + && isMadeOf typedefof> (info.Converter.GetType ()) + -> + match commonOptionsOf documentType with + | ValueSome common -> + let recordOptions = { + NamingPolicy = contract.PropertyNamingPolicy + IncludesProperties = common.IncludeRecordProperties + } + + // Two members that are written under one name, which the policy can make of two names, cannot be + // told apart in a document. + if areDistinct (writtenNamesOfRecord recordOptions documentType) then + Writer.Record recordOptions + else + Writer.Unknown + | ValueNone -> Writer.Unknown + | _ -> Writer.Unknown + ) + + /// + /// The entry that a contract has for a member, with the member that the entry was made of: the member itself, + /// or the override of it that the type of the contract has when the contract lists no other entry for it. What + /// the serializer reads from a member, it reads from the one the entry was made of. + /// + let propertyOf (info : JsonTypeInfo) (memberOfDocument : MemberInfo) : struct (JsonPropertyInfo * MemberInfo) voption = + let entries = seq { + for property in info.Properties do + match property.AttributeProvider with + | :? MemberInfo as own -> struct (property, own) + | _ -> () + } + + entries + |> Seq.tryFind (fun (struct (_, own)) -> isSameMember own memberOfDocument) + |> ValueOption.orElseWith (fun () -> + entries + |> Seq.tryFind (fun (struct (_, own)) -> isOverrideOf memberOfDocument own) + ) + + /// + /// Whether System.Text.Json never writes a member of an object: the member has no getter the serializer may + /// call. A member that is marked with + /// is one. + /// + let isNeverWritten (property : JsonPropertyInfo) : bool = + match property.Get with + | null -> true + | _ -> false + + /// The name of a member, by the rules of who writes its type. + let nameOf (memberOfDocument : DocumentMember) : string voption = + match writerOf memberOfDocument.Holder with + | Writer.Serializer info -> + match propertyOf info memberOfDocument.Member with + | ValueSome (struct (property, _)) when property.IsExtensionData -> ValueNone + | ValueSome (struct (property, own)) when isNeverWritten property -> declaredNameOf false own + | ValueSome (struct (property, _)) -> ValueSome property.Name + | ValueNone -> ValueNone + | Writer.Record recordOptions -> recordMemberNameOf recordOptions memberOfDocument.Member + | Writer.Unknown -> ValueNone + + /// + /// The contract that the serializer writes a value with: the one of its type. No contract when the layout does + /// not know what writes the value, or when the member that holds the value names a converter of its own: such + /// a converter writes the whole value of the member, and nothing shows what it writes. The value is asked + /// about by the member that holds it, when a member does, and by its type. + /// + let valueInfoOf (struct (memberOfDocument : DocumentMember voption, valueType : Type)) : JsonTypeInfo voption = + match memberOfDocument with + | ValueNone -> typeInfoOf valueType + | ValueSome memberOfDocument -> + match writerOf memberOfDocument.Holder with + | Writer.Serializer info -> + match propertyOf info memberOfDocument.Member with + // The entries of the extension data are properties of the document itself, so no property holds + // the dictionary. + | ValueSome (struct (property, _)) when property.IsExtensionData -> ValueNone + // Whatever writes a property that the serializer never writes decides how. + | ValueSome (struct (property, _)) when isNeverWritten property -> ValueNone + | ValueSome (struct (property, _)) -> + match property.CustomConverter with + | null -> typeInfoOf valueType + | _ -> ValueNone + | ValueNone -> ValueNone + | Writer.Record recordOptions -> + // FSharp.SystemTextJson does not read the converter that a member of a record names. A member + // that it does not write is described by nothing: whatever writes its property decides how. + if isWrittenByRecord recordOptions memberOfDocument.Member then + typeInfoOf valueType + else + ValueNone + | Writer.Unknown -> ValueNone + + /// + /// How an enumeration is written. The serializer is asked to write its values, because nothing else tells: + /// System.Text.Json has one converter for numbers and for names, which keeps to itself what it writes. + /// + /// + /// + /// Every value that has a name is written, and all of them have to come out as one kind of JSON value: a + /// converter of the application can write one value as its name and another as a number, and such an + /// enumeration is written in no one way. + /// + /// + /// A value of an enumeration can be any number under it, and a converter of names writes one that has no name + /// as its number. So the serializer is asked for two such values as well: the smallest number that no constant + /// has, and a combination of two constants that is no constant either. A number contradicts nothing, and + /// anything else has to be the kind that the values with a name come out as. A converter that writes some + /// other value in a way of its own is not noticed. A value that a converter refuses is no value of a + /// document, so the refusal of one of the two is no contradiction. + /// + /// + let enumEncodingOf (struct (_, valueType : Type) as question) : EnumEncoding = + let enumType = + match Nullable.GetUnderlyingType valueType with + | null -> valueType + | underlying -> underlying + + if not enumType.IsEnum then + EnumEncoding.NotDescribed + else + match valueInfoOf question with + | ValueNone -> EnumEncoding.NotDescribed + | ValueSome info -> + // The kind of JSON value that the serializer writes for a value; none when the converter refuses + // the value, as the one of names does when it was made to. These are the two exceptions that the + // serializer has for a value that a converter does not write. + let kindOf (value : obj) : JsonValueKind voption = + try + ValueSome (JsonSerializer.SerializeToElement(value, info).ValueKind) + with + | :? JsonException + | :? NotSupportedException -> ValueNone + + // Whether a value that has no name comes out as the values with a name do, or as a number. + let isWrittenLike (named : JsonValueKind) (value : obj) : bool = + match kindOf value with + | ValueNone + | ValueSome JsonValueKind.Number -> true + | ValueSome written -> written = named + + let constants = Seq.cast(Enum.GetValues enumType) |> Seq.toArray + + // The values with a name: a converter of names writes a value without one as its number. An + // enumeration that declares no value has only such a value to write. + let named = + if constants.Length = 0 then + [| Enum.ToObject (enumType, 0) |] + else + constants + + let unnamed = [| yield! undeclaredValueOf enumType constants; yield! combinationOf enumType constants |] + + let kinds = named |> Seq.map kindOf |> Seq.distinct |> Seq.toArray + + match kinds with + | [| ValueSome JsonValueKind.Number |] when unnamed |> Seq.forall (isWrittenLike JsonValueKind.Number) -> + EnumEncoding.Number + | [| ValueSome JsonValueKind.String |] when unnamed |> Seq.forall (isWrittenLike JsonValueKind.String) -> + EnumEncoding.String + | _ -> EnumEncoding.NotDescribed + + /// How a tuple is written: FSharp.SystemTextJson writes it as an array. + let tupleEncodingOf (struct (_, tupleType : Type) as question) : TupleEncoding = + if not (FSharpType.IsTuple tupleType) then + TupleEncoding.NotDescribed + else + match valueInfoOf question with + | ValueSome info when isTupleConverter (info.Converter.GetType ()) -> TupleEncoding.Array + | _ -> TupleEncoding.NotDescribed + + /// + /// How a collection is written: as an array when the contract says that the serializer writes its items, or + /// when a converter of FSharp.SystemTextJson for lists or sets writes it. + /// + let collectionEncodingOf (question : struct (DocumentMember voption * Type)) : CollectionEncoding = + match valueInfoOf question with + // The contract of a type whose items the serializer writes names the type of an item. + | ValueSome info when info.Kind = JsonTypeInfoKind.Enumerable -> CollectionEncoding.Array (nonNull info.ElementType) + | ValueSome info -> + let converter = info.Converter.GetType () + + if + isMadeOf typedefof> converter + || isMadeOf typedefof> converter + then + CollectionEncoding.Array (converter.GetGenericArguments()[0]) + else + CollectionEncoding.NotDescribed + | ValueNone -> CollectionEncoding.NotDescribed + + /// + /// How a map is written: as an object when the contract says that the serializer writes it as a dictionary, and + /// as the converter of FSharp.SystemTextJson that writes it does. + /// + let mapEncodingOf (question : struct (DocumentMember voption * Type)) : MapEncoding = + match valueInfoOf question with + // The contract of a dictionary names the types of a key and of a value. + | ValueSome info when info.Kind = JsonTypeInfoKind.Dictionary -> + MapEncoding.Object (nonNull info.KeyType, nonNull info.ElementType) + | ValueSome info -> + let converter = info.Converter.GetType () + + if isMadeOf typedefof> converter then + let arguments = converter.GetGenericArguments () + MapEncoding.Object (arguments[0], arguments[1]) + elif isMadeOf typedefof> converter then + let arguments = converter.GetGenericArguments () + MapEncoding.ArrayOfPairs (arguments[0], arguments[1]) + else + MapEncoding.NotDescribed + | ValueNone -> MapEncoding.NotDescribed + + /// + /// The one field of a case that is a record that the options unwrap: its members are written in place of the + /// fields. No type when the case does not write its fields that way. + /// + let unwrappedRecordOf (options : UnionOptions) (case : UnionCaseInfo) : Type voption = + match case.GetFields () with + | [| field |] when + FSharpType.IsRecord (field.PropertyType, AnyAccessibility) + && options.Encoding.HasFlag JsonUnionEncoding.UnwrapRecordCases + -> + ValueSome field.PropertyType + | _ -> ValueNone + + /// + /// Whether FSharp.SystemTextJson writes a case as an object that has the name of the tag twice: next to an + /// internal tag, a field with that name, or a member with that name of the record whose members the case + /// writes. The library writes such a document and reads it back, but a query reads one property of a name, + /// and nothing says which of the two it is. A case that writes the members of a record that the layout does not + /// describe is taken to do so: the union writes them under names that nothing shows. + /// + let repeatsTag (options : UnionOptions) (case : UnionCaseInfo) : bool = + let isInternalTag = int options.Encoding &&& UnionFormatBits = int JsonUnionEncoding.InternalTag + + if + not ( + isInternalTag + && options.Encoding.HasFlag JsonUnionEncoding.NamedFields + ) + then + false + else + let namesNextToTag = + match unwrappedRecordOf options case with + | ValueSome recordType -> + match writerOf recordType with + | Writer.Record recordOptions -> ValueSome (writtenNamesOfRecord recordOptions recordType) + | _ -> ValueNone + | ValueNone -> ValueSome (unionFieldNamesOf options case) + + match namesNextToTag with + | ValueSome names -> + names + |> Array.exists (fun name -> String.Equals (name, options.TagName, StringComparison.Ordinal)) + | ValueNone -> true + + /// + /// Whether the layout describes a union: no case is represented by null, every tag is a text and no two cases + /// have the same one, no case declares the names of its fields, and no case writes the name of the tag twice. A + /// union is described as a whole, because a document of one case can hold the tag of another. + /// + let isUnionDescribed (options : UnionOptions) (unionType : Type) : bool = + let cases = FSharpType.GetUnionCases (unionType, AnyAccessibility) + let tags = cases |> Array.map (unionTagOf options.TagNamingPolicy) + + not (hasNullCase unionType) + && tags |> Array.forall _.IsSome + // Two cases with one tag are written with one mark: a name that two cases declare, or that a naming policy + // makes of two names. + && areDistinct (tags |> Array.map _.Value) + && cases + |> Array.forall (fun case -> + not (declaresFieldNames case) + && not (repeatsTag options case) + ) + + /// + /// How FSharp.SystemTextJson writes a case of a union with the common options. The rules are read from the + /// source of the library and compared with what it writes. + /// + /// + /// + /// A case without fields is its tag alone when such tags are unwrapped. Otherwise the encoding decides where + /// the tag is: in a property next to the property of the fields, or as the first item or a property among the + /// fields. + /// + /// + /// The fields are an array of their values or an object with a property for each. A case whose one field is a + /// record writes the members of the record in place of the fields where the encoding unwraps records. The + /// converter of the union writes such a record with the options that it has, so the case is described only + /// when the record by itself is written by FSharp.SystemTextJson with the same options: then the object is + /// the record as it is written anywhere, and + /// + /// names its members. Only next to an internal tag is the object more than the record. + /// + /// + let writtenCaseOf (options : UnionOptions) (case : UnionCaseInfo) (tag : string) : UnionCaseEncoding = + let encoding = options.Encoding + let fields = case.GetFields () + let hasNamedFields = encoding.HasFlag JsonUnionEncoding.NamedFields + let root = ImmutableArray.Empty + let step (container : ImmutableArray) (next : JsonStep) : ImmutableArray = container.Add next + + // The fields as the properties of the object at the end of the steps, which holds the tag as well or not; + // no places when the record that the case unwraps is not written as the layout describes a record. + let asProperties (container : ImmutableArray) (holdsTag : bool) : ImmutableArray voption = + match unwrappedRecordOf options case with + | ValueSome recordType -> + match writerOf recordType with + | Writer.Record _ when holdsTag -> ValueSome (ImmutableArray.Create (UnionFieldPlace.Members container)) + // Without a tag in it the object is the record as it is written anywhere. + | Writer.Record _ -> ValueSome (ImmutableArray.Create (UnionFieldPlace.Value container)) + | _ -> ValueNone + | ValueNone -> + unionFieldNamesOf options case + |> Seq.map (fun name -> UnionFieldPlace.Value (step container (JsonStep.Property name))) + |> ImmutableArray.CreateRange + |> ValueSome + + // The fields as the items of the array at the end of the steps, from the index that is given. + let asItems (container : ImmutableArray) (first : int) : ImmutableArray voption = + fields + |> Seq.mapi (fun index _ -> UnionFieldPlace.Value (step container (JsonStep.Item (first + index)))) + |> ImmutableArray.CreateRange + |> ValueSome + + let written (path : ImmutableArray) (places : ImmutableArray voption) : UnionCaseEncoding = + match places with + | ValueSome places -> UnionCaseEncoding.Written (UnionCaseMark.Tag (path, tag), places) + | ValueNone -> UnionCaseEncoding.NotDescribed + + if + fields.Length = 0 + && encoding.HasFlag JsonUnionEncoding.UnwrapFieldlessTags + then + written root (ValueSome ImmutableArray.Empty) + else + match int encoding &&& UnionFormatBits with + // No bit says where the tag is: next to the fields. + | 0 -> + let container = ImmutableArray.Create (JsonStep.Property options.FieldsName) + + written + (ImmutableArray.Create (JsonStep.Property options.TagName)) + (if hasNamedFields then + asProperties container false + else + asItems container 0) + | bits when bits = int JsonUnionEncoding.InternalTag -> + if hasNamedFields then + written (ImmutableArray.Create (JsonStep.Property options.TagName)) (asProperties root true) + else + written (ImmutableArray.Create (JsonStep.Item 0)) (asItems root 1) + // Another place for the tag: the options are refused when the layout is made. + | _ -> UnionCaseEncoding.NotDescribed + + /// + /// How a case of a union is written. The contract of the union names the converter, and the converters of + /// FSharp.SystemTextJson for unions are told by their classes; the options that the union is written with + /// say the rest. + /// + let unionCaseEncodingOf (struct (memberOfDocument : DocumentMember voption, case : UnionCaseInfo)) : UnionCaseEncoding = + let unionType = case.DeclaringType + + match valueInfoOf (struct (memberOfDocument, unionType)) with + | ValueNone -> UnionCaseEncoding.NotDescribed + | ValueSome info -> + let converter = info.Converter.GetType () + + if isMadeOf typedefof> converter then + // The class says all of it: the one field of the one case is written in place of the union. + UnionCaseEncoding.Written ( + UnionCaseMark.Unmarked, + ImmutableArray.Create (UnionFieldPlace.Value ImmutableArray.Empty) + ) + elif + isMadeBySerializer info + && (isMadeOf typedefof> converter + || isMadeOf typedefof> converter) + then + match unionOptionsOf unionType with + | ValueSome options when isUnionDescribed options unionType -> + match unionTagOf options.TagNamingPolicy case with + | ValueSome tag -> writtenCaseOf options case tag + | ValueNone -> UnionCaseEncoding.NotDescribed + | _ -> UnionCaseEncoding.NotDescribed + else + UnionCaseEncoding.NotDescribed + + /// + /// How a type with derived types is written: what the contract of the type says of its polymorphism. + /// + let polymorphismOf (baseType : Type) : PolymorphismEncoding = + match typeInfoOf baseType with + | ValueNone -> PolymorphismEncoding.NotDescribed + | ValueSome info -> + match info.PolymorphismOptions with + | null -> PolymorphismEncoding.NotPolymorphic + | polymorphism -> + let derived = + polymorphism.DerivedTypes + |> Seq.map (fun derived -> + match derived.TypeDiscriminator with + | null -> ValueSome { Type = derived.DerivedType; Discriminator = ValueNone } + | :? string as text -> ValueSome { Type = derived.DerivedType; Discriminator = ValueSome text } + | _ -> ValueNone + ) + |> Seq.toArray + + if derived |> Array.exists _.IsNone then + PolymorphismEncoding.NotDescribed + else + PolymorphismEncoding.Polymorphic ( + polymorphism.TypeDiscriminatorPropertyName, + derived |> Seq.map _.Value |> ImmutableArray.CreateRange + ) + + let rememberedName = remembered nameOf + let rememberedEnumEncoding = remembered enumEncodingOf + let rememberedUnionCaseEncoding = remembered unionCaseEncodingOf + + interface IJsonLayout with + + /// + member _.MemberName (memberOfDocument : DocumentMember) : string voption = rememberedName memberOfDocument + + /// + member _.EnumEncoding (memberOfDocument : DocumentMember voption, enumType : Type) : EnumEncoding = + rememberedEnumEncoding (struct (memberOfDocument, enumType)) + + /// + member _.TupleEncoding (memberOfDocument : DocumentMember voption, tupleType : Type) : TupleEncoding = + tupleEncodingOf (struct (memberOfDocument, tupleType)) + + /// + member _.CollectionEncoding (memberOfDocument : DocumentMember voption, collectionType : Type) : CollectionEncoding = + collectionEncodingOf (struct (memberOfDocument, collectionType)) + + /// + member _.MapEncoding (memberOfDocument : DocumentMember voption, mapType : Type) : MapEncoding = + mapEncodingOf (struct (memberOfDocument, mapType)) + + /// + member _.UnionCaseEncoding (memberOfDocument : DocumentMember voption, case : UnionCaseInfo) : UnionCaseEncoding = + rememberedUnionCaseEncoding (struct (memberOfDocument, case)) + + /// + member _.Polymorphism (baseType : Type) : PolymorphismEncoding = polymorphismOf baseType + + /// + /// The layout of the documents that System.Text.Json writes with and the converter of + /// FSharp.SystemTextJson, or the reasons why the layout cannot describe them. Pass the options that the Cosmos DB + /// client serializes with. + /// + /// + /// + /// The layout supports the set-ups that it has been compared with the serializer for, and refuses the others + /// instead of describing them wrongly: a query that reads a property that is not there returns nothing, and no + /// error says why. It is made when + /// + /// + /// + /// one converter of FSharp.SystemTextJson, of that class itself, is among the options, and it writes every kind + /// of type of F#; + /// + /// + /// the unions are written with an adjacent or an internal tag, an option as its value (UnwrapOption), and + /// without the flags UnwrapSingleFieldCases and UnionFieldNamesFromTypes, and an adjacent tag is + /// written under another name than the fields; + /// + /// + /// the options neither handle references nor write numbers as texts nor ignore read-only members. + /// + /// + /// + /// The layout reads when it is made and keeps a copy, so a change of them afterwards + /// does not reach it. What it finds out about a member is kept for as long as the layout is. + /// + /// + /// The resolver of the contracts, , is not + /// copied: it can be any object, so the layout asks the one that the serializer asks. A change of that resolver + /// before the layout is asked for the first time reaches the layout as it reaches the serializer. From that + /// question on a refuses a + /// change of its , + /// as it does after the first document is written, so the layout and the serializer cannot come to disagree + /// unnoticed. A resolver of the application has to give one answer for a type every time it is asked, which the + /// serializer needs as well. + /// + /// + /// It describes the members of the types that System.Text.Json writes as objects and of the records that + /// FSharp.SystemTextJson writes with its common options: a record or a union that has options of its own, in the + /// overrides or in an attribute, is not described. A member of a type that another converter writes has no name + /// here, and neither has a member of a record whose contract a resolver of the application made from a + /// converter: nothing shows how that converter was made. + /// + /// + /// An enumeration, a tuple, a collection and a map are described as System.Text.Json and FSharp.SystemTextJson + /// write them, by the converter that the options have for the type. What a converter of the application writes is + /// not described, except for an enumeration: the layout has the serializer write every value of it that has a + /// name, and describes the enumeration when numbers come out for all of them or strings for all of them. An + /// enumeration whose values come out in both ways is not described, and neither is one whose converter refuses a + /// value. A member that names a converter of its own is not described either. + /// + /// + /// The options of the serializer. + /// The layout, or one sentence for every setting of the options that the layout does not support. + let ofSerializerOptions (options : JsonSerializerOptions) : Result> = + let refusals = refusalsOf options + + if refusals.IsEmpty then + Result.Ok (SerializerLayout options :> IJsonLayout) + else + Result.Error refusals diff --git a/tests/Cosmos.Quotations.Tests/TestCategories.fs b/tests/Cosmos.Quotations.Tests/TestCategories.fs index 797d5ccb..1e8348c0 100644 --- a/tests/Cosmos.Quotations.Tests/TestCategories.fs +++ b/tests/Cosmos.Quotations.Tests/TestCategories.fs @@ -15,6 +15,16 @@ type EvaluatorUnitTestCategoryAttribute () = /// override _.TestCategories = [| "Unit"; "Evaluator" |] :> IList +/// +/// Categorizes a unit test of the layout that says how the serializer writes the members of a document: +/// . +/// +type JsonLayoutUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "JsonLayout" |] :> IList + /// /// Categorizes a unit test of the normalizer: /// , From 762025ffd3006fb99c5a49dc0892d805f1baa804 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Mon, 12 Oct 2026 12:34:33 +0200 Subject: [PATCH 10/10] test(quotations): compare the layout with what the serializer writes Every answer of the layout is compared with a document that the real serializer writes. A model of types is serialized with every way to set the serializer up that the layout supports: the defaults of FSharp.SystemTextJson with one change at a time, and the options that the maintainer's application writes its documents with. The layout has to say of each member the name of its property, of each enumeration, tuple, collection and map the kind of JSON value, of each case of a union the steps to its tag and to its fields, and of each derived type its discriminator, as the document has them. What the layout does not describe is tested the same way, with the serializer as the judge: a member with a converter of its own, a type that a converter of the application writes, a record or a union with options of its own, a union with a case that is null, with tags that are numbers, or with a name that is written twice, and a type that a resolver of the application made a contract of. Each set-up that is refused has a test that names the reason. A converter of an enumeration that writes a value in a way of its own is tested with what the layout should say: zero, the number after the last constant, a combination of two constants, null and a refusal, next to the converters of System.Text.Json for names and for numbers. The model has a type for every case, and a count of how often the serializer is asked, which shows that an answer is worked out once. Co-Authored-By: Claude Sonnet 5.5 --- ...Sharp.Azure.Cosmos.Quotations.Tests.fsproj | 9 + .../JsonLayoutPolymorphismTests.fs | 193 +++ .../JsonLayoutTests.fs | 1259 +++++++++++++++++ .../JsonLayoutUnionTests.fs | 601 ++++++++ .../JsonLayoutValueTests.fs | 680 +++++++++ tests/Cosmos.Quotations.Tests/ModelMembers.fs | 47 + tests/Cosmos.Quotations.Tests/StoredModel.fs | 529 +++++++ tests/Cosmos.Quotations.Tests/StoredUnions.fs | 386 +++++ tests/Cosmos.Quotations.Tests/StoredValues.fs | 423 ++++++ .../Cosmos.Quotations.Tests/TestCategories.fs | 7 +- .../WrittenDocuments.fs | 335 +++++ 11 files changed, 4467 insertions(+), 2 deletions(-) create mode 100644 tests/Cosmos.Quotations.Tests/JsonLayoutPolymorphismTests.fs create mode 100644 tests/Cosmos.Quotations.Tests/JsonLayoutTests.fs create mode 100644 tests/Cosmos.Quotations.Tests/JsonLayoutUnionTests.fs create mode 100644 tests/Cosmos.Quotations.Tests/JsonLayoutValueTests.fs create mode 100644 tests/Cosmos.Quotations.Tests/ModelMembers.fs create mode 100644 tests/Cosmos.Quotations.Tests/StoredModel.fs create mode 100644 tests/Cosmos.Quotations.Tests/StoredUnions.fs create mode 100644 tests/Cosmos.Quotations.Tests/StoredValues.fs create mode 100644 tests/Cosmos.Quotations.Tests/WrittenDocuments.fs diff --git a/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj b/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj index 20d866ec..94681caa 100644 --- a/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj +++ b/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj @@ -36,6 +36,15 @@ + + + + + + + + + diff --git a/tests/Cosmos.Quotations.Tests/JsonLayoutPolymorphismTests.fs b/tests/Cosmos.Quotations.Tests/JsonLayoutPolymorphismTests.fs new file mode 100644 index 00000000..6a3d87f1 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/JsonLayoutPolymorphismTests.fs @@ -0,0 +1,193 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open System.Text.Json +open System.Text.Json.Serialization +open Microsoft.VisualStudio.TestTools.UnitTesting + +open FSharp.Azure.Cosmos +open FSharp.Azure.Cosmos.Quotations + +/// The base of a hierarchy that is written with a discriminator, named by the type. +[, "dog+v1"); JsonDerivedType(typeof, "cat+v1")>] +type StoredAnimal () = + + /// A property of every animal. + member val Name = "" with get, set + +/// A derived class. +and StoredDog () = + inherit StoredAnimal () + +/// Another derived class. +and StoredCat () = + inherit StoredAnimal () + +/// A base of a hierarchy that is written with a discriminator under a name of its own, and one derived class without. +[, "car"); + JsonDerivedType(typeof)>] +type StoredVehicle () = + + /// A property of every vehicle. + member val Plate = "" with get, set + +/// A derived class with a discriminator. +and StoredCar () = + inherit StoredVehicle () + +/// A derived class without one. +and StoredTruck () = + inherit StoredVehicle () + +/// A base of a hierarchy whose discriminators are numbers. +[, 1)>] +type StoredShip () = + + /// A property of every ship. + member val Name = "" with get, set + +/// A derived class with a number as its discriminator. +and StoredBoat () = + inherit StoredShip () + +/// +/// What says about types with derived types, compared with +/// what the serializer writes for a derived type that it writes as its base. +/// +[] +type JsonLayoutPolymorphismTests () = + + /// The layout of FSharp.SystemTextJson as it is made. + static let layout () : IJsonLayout = LayoutAssert.WantLayout (SerializerProfiles.fsharpDefault.Create ()) + + /// Every way to set the serializer up that the layout supports. + static member ProfileRows : IEnumerable> = + SerializerProfiles.supported + |> Seq.map (fun profile -> + TestDataRow( + profile, + DisplayName = $"a type with derived types must be laid out as it is written by %s{profile.Name}" + ) + ) + + [] + member _.``A derived type must be written with the discriminator that the layout says`` (profile : SerializerProfile) = + let options = profile.Create () + let layout = LayoutAssert.WantLayout options + + let check (baseType : Type) (animals : (Type * objnull) seq) = + match layout.Polymorphism baseType with + | PolymorphismEncoding.Polymorphic (property, derivedTypes) -> + for derived in derivedTypes do + let value = + animals + |> Seq.pick (fun (valueType, value) -> + if Type.(=) (valueType, derived.Type) then + Some value + else + None + ) + + let written = JsonSerializer.SerializeToElement (value, baseType, options) + + match derived.Discriminator, written.TryGetProperty property with + | ValueSome discriminator, (true, found) -> + Assert.AreEqual( + discriminator, + found.GetString (), + $"The document of %s{derived.Type.Name} should hold the discriminator under %s{property} (%s{profile.Name})." + ) + | ValueNone, (false, _) -> () + | said, (found, _) -> + Assert.Fail + $"%s{derived.Type.Name}: the layout says %A{said}, and the document holds the property: %b{found}" + | other -> Assert.Fail $"%s{baseType.Name} should be polymorphic, but the layout says %A{other}" + + check + typeof + (seq { + (typeof, box (StoredDog ())) + (typeof, box (StoredCat ())) + }) + + check + typeof + (seq { + (typeof, box (StoredCar ())) + (typeof, box (StoredTruck ())) + }) + + [] + member _.``The derived types of a type must be the ones that it declares, with their discriminators`` () = + match (layout ()).Polymorphism typeof with + | PolymorphismEncoding.Polymorphic (property, derivedTypes) -> + Assert.AreEqual("$type", property, "The discriminator has the name that System.Text.Json gives it.") + + CollectionAssert.AreEquivalent ( + [| struct (typeof, ValueSome "dog+v1"); struct (typeof, ValueSome "cat+v1") |], + derivedTypes + |> Seq.map (fun derived -> struct (derived.Type, derived.Discriminator)) + |> Seq.toArray, + "Every derived type that the type declares has the discriminator that it declares." + ) + | other -> Assert.Fail $"The type should be polymorphic, but the layout says %A{other}" + + [] + member _.``A discriminator that has a name of its own must have it`` () = + match (layout ()).Polymorphism typeof with + | PolymorphismEncoding.Polymorphic (property, derivedTypes) -> + Assert.AreEqual("kind", property, "The attribute of the type names the property.") + + Assert.IsTrue ( + derivedTypes + |> Seq.exists (fun derived -> + Type.(=) (derived.Type, typeof) + && derived.Discriminator.IsNone + ), + "A derived type that declares no discriminator has none." + ) + | other -> Assert.Fail $"The type should be polymorphic, but the layout says %A{other}" + + [] + member _.``A type without derived types must not be polymorphic`` () = + let layout = layout () + + for valueType in + seq { + typeof + typeof + typeof + typeof + typeof + } do + Assert.AreEqual( + PolymorphismEncoding.NotPolymorphic, + layout.Polymorphism valueType, + $"%s{valueType.Name} declares no derived types." + ) + + [] + member _.``A type whose discriminators are numbers must not be described`` () = + Assert.AreEqual( + "{\"$type\":1,\"Name\":\"\"}", + JsonSerializer.Serialize(StoredBoat (), SerializerProfiles.fsharpDefault.Create ()), + "The serializer should write the number, or the test checks nothing." + ) + + Assert.AreEqual( + PolymorphismEncoding.NotDescribed, + (layout ()).Polymorphism typeof, + "A discriminator that is a number is no text to compare with." + ) + + [] + member _.``A type that the serializer refuses must not be described`` () = + Assert.AreEqual( + PolymorphismEncoding.NotDescribed, + (layout ()).Polymorphism typeof, + "The serializer has no contract for the type." + ) diff --git a/tests/Cosmos.Quotations.Tests/JsonLayoutTests.fs b/tests/Cosmos.Quotations.Tests/JsonLayoutTests.fs new file mode 100644 index 00000000..4f3ce71f --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/JsonLayoutTests.fs @@ -0,0 +1,1259 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections +open System.Collections.Generic +open System.Collections.Immutable +open System.Reflection +open System.Text.Json +open System.Text.Json.Serialization +open System.Text.Json.Serialization.Metadata +open System.Threading +open System.Threading.Tasks +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations +open FSharp.Quotations.Patterns +open FSharp.Reflection + +open FSharp.Azure.Cosmos +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// A way to set up the serializer, as a function that makes its options anew: a test may change what it gets. +[] +type SerializerProfile = { + /// What is special about the options; the name of a test result holds it. + Name : string + /// Makes the options. + Create : unit -> JsonSerializerOptions +} + +/// +/// The ways to set up the serializer that the layout supports, and some that it refuses. The tests write the model +/// with every supported way and compare the layout with the documents. +/// +module SerializerProfiles = + + /// Options with the converter of FSharp.SystemTextJson. + let private fsharp + (name : string) + (configureConverter : JsonFSharpOptions -> JsonFSharpOptions) + (configure : JsonSerializerOptions -> unit) + : SerializerProfile = { + Name = name + Create = + fun () -> + let options = (configureConverter (JsonFSharpOptions.Default ())).ToJsonSerializerOptions() + configure options + options + } + + /// FSharp.SystemTextJson as it is made. + let fsharpDefault = fsharp "FSharp.SystemTextJson with its defaults" id ignore + + /// + /// The options of FSharp.SystemTextJson that the application of the maintainer writes its documents with: an + /// internal tag named $type, named fields, a record in a case unwrapped, options that are always skipped, + /// and maps as objects. + /// + let private productionOptions : JsonFSharpOptions = + JsonFSharpOptions( + JsonUnionEncoding.InternalTag + ||| JsonUnionEncoding.AllowUnorderedTag + ||| JsonUnionEncoding.NamedFields + ||| JsonUnionEncoding.UnwrapSingleCaseUnions + ||| JsonUnionEncoding.UnwrapRecordCases + ||| JsonUnionEncoding.UnwrapOption + ||| JsonUnionEncoding.UnwrapFieldlessTags, + unionTagName = "$type" + ) + .WithSkippableOptionFields(SkippableOptionFields.Always, true) + .WithMapFormat(MapFormat.Object) + + /// The set-up of that application, with camel case names and enumerations by name. + let production = + fsharp + "the options of the application: an internal tag, camel case names and enumerations by name" + (fun _ -> productionOptions) + (fun options -> + options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase + options.Converters.Add (JsonStringEnumConverter ()) + ) + + /// Every way to set the serializer up that the layout supports. + let supported = + seq { + fsharpDefault + fsharp + "FSharp.SystemTextJson with camel case names" + id + (fun options -> options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase) + fsharp + "FSharp.SystemTextJson with snake case names that includes fields" + id + (fun options -> + options.PropertyNamingPolicy <- JsonNamingPolicy.SnakeCaseLower + options.IncludeFields <- true + ) + fsharp "FSharp.SystemTextJson that includes the properties of records" _.WithIncludeRecordProperties() ignore + fsharp + "FSharp.SystemTextJson that reads numbers from texts" + id + (fun options -> options.NumberHandling <- JsonNumberHandling.AllowReadingFromString) + fsharp + "FSharp.SystemTextJson that writes enumerations by name" + id + (fun options -> options.Converters.Add (JsonStringEnumConverter ())) + fsharp "FSharp.SystemTextJson that writes every map as an object" _.WithMapFormat(MapFormat.Object) ignore + fsharp + "FSharp.SystemTextJson that writes every map as an array of pairs" + _.WithMapFormat(MapFormat.ArrayOfPairs) + ignore + fsharp + "FSharp.SystemTextJson that writes the tag next to the fields, which have names" + _.WithUnionNamedFields() + ignore + fsharp + "FSharp.SystemTextJson that writes a case without fields as its tag, with a naming policy for the tags" + _.WithUnionTagNamingPolicy(JsonNamingPolicy.SnakeCaseUpper).WithUnionUnwrapFieldlessTags() + ignore + fsharp + "FSharp.SystemTextJson that writes the members of a record in place of the fields" + _.WithUnionEncoding( + JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapRecordCases + ||| JsonUnionEncoding.UnwrapOption + ||| JsonUnionEncoding.UnwrapSingleCaseUnions + ) + ignore + fsharp + "FSharp.SystemTextJson with names of its own for the tag and the fields of a union" + _.WithUnionTagName("kind").WithUnionFieldsName("data").WithUnionNamedFields() + ignore + fsharp + "FSharp.SystemTextJson with a naming policy for the fields of a union and camel case names" + _.WithUnionNamedFields().WithUnionFieldNamingPolicy(JsonNamingPolicy.SnakeCaseUpper) + (fun options -> options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase) + fsharp + "FSharp.SystemTextJson that writes the tag before the fields" + _.WithUnionEncoding( + JsonUnionEncoding.InternalTag + ||| JsonUnionEncoding.UnwrapOption + ||| JsonUnionEncoding.UnwrapSingleCaseUnions + ) + ignore + fsharp + "FSharp.SystemTextJson that writes the tag among the fields, which have names" + _.WithUnionInternalTag().WithUnionNamedFields() + ignore + fsharp + "FSharp.SystemTextJson that writes the tag among the fields under the name that the fields would have" + _.WithUnionInternalTag().WithUnionNamedFields().WithUnionTagName("Fields") + ignore + fsharp + "FSharp.SystemTextJson that writes the tag next to the fields under the name of a field" + _.WithUnionNamedFields().WithUnionTagName("radius") + ignore + fsharp + "FSharp.SystemTextJson that writes the tag before the fields under the name of a field" + _ + .WithUnionEncoding( + JsonUnionEncoding.InternalTag + ||| JsonUnionEncoding.UnwrapOption + ||| JsonUnionEncoding.UnwrapSingleCaseUnions + ) + .WithUnionTagName("radius") + ignore + fsharp + "FSharp.SystemTextJson that writes the tag among the members of a record" + _.WithUnionEncoding( + JsonUnionEncoding.InternalTag + ||| JsonUnionEncoding.UnwrapRecordCases + ||| JsonUnionEncoding.UnwrapOption + ||| JsonUnionEncoding.UnwrapSingleCaseUnions + ) + ignore + fsharp + "FSharp.SystemTextJson that does not write a union of one case as its value" + _.WithUnionEncoding( + JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapOption + ) + ignore + production + fsharp + "the options of the application with snake case names" + (fun _ -> productionOptions) + (fun options -> + options.PropertyNamingPolicy <- JsonNamingPolicy.SnakeCaseLower + options.Converters.Add (JsonStringEnumConverter ()) + ) + } + |> ImmutableArray.CreateRange + + /// The supported way to set the serializer up whose name has a part. + let named (part : string) : SerializerProfile = + supported + |> Seq.find (fun profile -> profile.Name.Contains (part, StringComparison.Ordinal)) + + /// + /// A way to set the serializer up that the layout refuses, with a part of the reason that the layout gives. The + /// options come from a function, because a test may change what it gets. + /// + [] + type Refusal = { + /// What is special about the options; the name of a test result holds it. + Name : string + /// Makes the options. + Create : unit -> JsonSerializerOptions + /// A part of the sentence that says why. + Reason : string + } + + /// FSharp.SystemTextJson with a change of the encoding of its unions. + let private encoded (encoding : JsonUnionEncoding) : unit -> JsonSerializerOptions = + fun () -> (JsonFSharpOptions.Default().WithUnionEncoding encoding).ToJsonSerializerOptions() + + /// Every way to set the serializer up that the layout refuses. + let refused = + seq { + { + Name = "System.Text.Json alone" + Create = fun () -> JsonSerializerOptions () + Reason = "FSharp.SystemTextJson is not among the converters" + } + { + Name = "two converters of FSharp.SystemTextJson" + Create = + fun () -> + let options = JsonSerializerOptions () + options.Converters.Add ( + JsonFSharpConverter (JsonFSharpOptions.Default().WithTypes JsonFSharpTypes.Unions) + ) + options.Converters.Add (JsonFSharpConverter (JsonFSharpOptions.Default ())) + options + Reason = "More than one converter of FSharp.SystemTextJson" + } + { + Name = "a converter that is derived from the one of FSharp.SystemTextJson" + Create = + fun () -> + let options = JsonSerializerOptions () + options.Converters.Add (StoredDerivedFactory ()) + options + Reason = "an application derived from it" + } + { + Name = "FSharp.SystemTextJson without its converters of tuples" + Create = + fun () -> + (JsonFSharpOptions.Default().WithTypes(JsonFSharpTypes.All &&& ~~~JsonFSharpTypes.Tuples)) + .ToJsonSerializerOptions() + Reason = "JsonFSharpTypes.All" + } + { + Name = "FSharp.SystemTextJson that does not write an option as its value" + Create = encoded JsonUnionEncoding.AdjacentTag + Reason = "UnwrapOption is not set" + } + { + Name = "FSharp.SystemTextJson that writes the tag as the name of the fields" + Create = + encoded ( + JsonUnionEncoding.ExternalTag + ||| JsonUnionEncoding.UnwrapOption + ) + Reason = "ExternalTag and Untagged" + } + { + Name = "FSharp.SystemTextJson that writes a union without a tag" + Create = + encoded ( + JsonUnionEncoding.Untagged + ||| JsonUnionEncoding.UnwrapOption + ) + Reason = "ExternalTag and Untagged" + } + { + Name = "FSharp.SystemTextJson with two places for the tag" + Create = + encoded ( + JsonUnionEncoding.ExternalTag + ||| JsonUnionEncoding.InternalTag + ||| JsonUnionEncoding.UnwrapOption + ) + Reason = "ExternalTag and Untagged" + } + { + Name = "FSharp.SystemTextJson that writes the one field of a case in place of the fields" + Create = + encoded ( + JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapOption + ||| JsonUnionEncoding.UnwrapSingleFieldCases + ) + Reason = "UnwrapSingleFieldCases" + } + { + Name = "FSharp.SystemTextJson that names the fields of a union after their types" + Create = + encoded ( + JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapOption + ||| JsonUnionEncoding.NamedFields + ||| JsonUnionEncoding.UnionFieldNamesFromTypes + ) + Reason = "UnionFieldNamesFromTypes" + } + { + Name = "FSharp.SystemTextJson that writes the tag and the fields under one name" + Create = + fun () -> + (JsonFSharpOptions.Default().WithUnionTagName("data").WithUnionFieldsName "data") + .ToJsonSerializerOptions() + Reason = "under one name" + } + { + Name = "options that handle references" + Create = + fun () -> + let options = JsonFSharpOptions.Default().ToJsonSerializerOptions() + options.ReferenceHandler <- ReferenceHandler.Preserve + options + Reason = "handle references" + } + { + Name = "options that write numbers as texts" + Create = + fun () -> + let options = JsonFSharpOptions.Default().ToJsonSerializerOptions() + options.NumberHandling <- JsonNumberHandling.WriteAsString + options + Reason = "numbers as texts" + } + { + Name = "options that ignore read-only properties" + Create = + fun () -> + let options = JsonFSharpOptions.Default().ToJsonSerializerOptions() + options.IgnoreReadOnlyProperties <- true + options + Reason = "read-only properties" + } + { + Name = "options that ignore read-only fields" + Create = + fun () -> + let options = JsonFSharpOptions.Default().ToJsonSerializerOptions() + options.IgnoreReadOnlyFields <- true + options + Reason = "read-only fields" + } + } + |> ImmutableArray.CreateRange + +/// +/// of +/// : +/// what the layout says about a member is what the serializer writes for it. The serializer is the oracle: every type +/// of the model is written with every way to set the serializer up that the layout supports, and the document is +/// searched for each member. +/// +[] +type JsonLayoutTests () = + + /// + /// The text or the number that a value comes down to when the options and value options around it are taken off; + /// no value for a value that is absent at any level, and for a value of another kind. + /// + static let rec scalarOf (value : objnull) : objnull voption = + match value with + | null -> ValueNone + | :? string + | :? int -> ValueSome value + // A collection of one item is found by that item. A list of F# is a union, so this comes first. + | :? IEnumerable as items when (items |> Seq.cast |> Seq.truncate 2 |> Seq.length) = 1 -> + items |> Seq.cast |> Seq.head |> scalarOf + | value -> + let valueType = value.GetType () + + // A union is found by what the one field of its case holds: an option and a value option are such unions. + if FSharpType.IsUnion valueType then + match FSharpValue.GetUnionFields (value, valueType) with + | _, [| inner |] -> scalarOf inner + | _ -> ValueNone + elif FSharpType.IsRecord valueType then + // A record is found by what its first field holds. + let fields = FSharpValue.GetRecordFields value + scalarOf fields[0] + else + ValueNone + + /// Whether a JSON value is a text or a number, or holds it somewhere inside. + static let rec holds (scalar : objnull) (json : JsonElement) : bool = + match json.ValueKind, scalar with + | JsonValueKind.String, (:? string as text) -> json.GetString () = text + | JsonValueKind.Number, (:? int as number) -> json.GetInt32 () = number + | JsonValueKind.Object, _ -> + json.EnumerateObject () + |> Seq.exists (fun property -> holds scalar property.Value) + | JsonValueKind.Array, _ -> json.EnumerateArray () |> Seq.exists (holds scalar) + | _ -> false + + /// The name of the property of a document that holds a text or a number. + static let propertyHolding (scalar : objnull) (document : JsonElement) : string voption = + document.EnumerateObject () + |> Seq.tryFind (fun property -> holds scalar property.Value) + |> ValueOption.map _.Name + + /// + /// Everything the layout says about the names of the members of a sample that the document of the sample does not + /// confirm; empty when the layout is right. + /// + static let disagreements (profile : SerializerProfile) (sample : StoredSample) : string array = + let options = profile.Create () + let layout = LayoutAssert.WantLayout options + let documentType = sample.Value.GetType () + let written = JsonSerializer.SerializeToElement (sample.Value, documentType, options) + + let scalars = + ModelMembers.ofType documentType + |> Seq.map (fun dataMember -> struct (dataMember, scalarOf (ModelMembers.valueOf sample.Value dataMember))) + |> Seq.toArray + + // A member can be found in the document only by a value that no other member holds. + let isUnique (scalar : objnull) = + let holders = + scalars + |> Seq.filter (fun (struct (_, other)) -> other = ValueSome scalar) + |> Seq.length + + holders = 1 + + seq { + for struct (dataMember, scalar) in scalars do + match scalar with + | ValueSome scalar when isUnique scalar -> + let writtenName = propertyHolding scalar written + + // A member that is never written and declares a name stands for a property that something else + // writes. Its name is no fact of these documents, and tests of their own state it. + let isDeclaredOnly = + writtenName.IsNone + && dataMember.IsDefined (typeof, false) + + let name = layout.MemberName { Holder = documentType; Member = dataMember } + + if not isDeclaredOnly && name <> writtenName then + $"%s{dataMember.Name}: the layout names it %A{name}, the document %A{writtenName}" + | _ -> () + } + |> Seq.toArray + + /// The layout of the options of a profile. + static let layoutOf (profile : SerializerProfile) : IJsonLayout = LayoutAssert.WantLayout (profile.Create ()) + + /// A property of a type of the model, also one that is not public, as a value of that type has it. + static let propertyOf (documentType : Type) (name : string) : DocumentMember = + match + documentType.GetProperty ( + name, + BindingFlags.Instance + ||| BindingFlags.Public + ||| BindingFlags.NonPublic + ) + with + | null -> invalidOp $"%s{documentType.Name} has no property %s{name}." + | property -> { Holder = documentType; Member = property } + + /// + /// The property that a quotation reads from its parameter, as the quotation names it, with the type of the + /// parameter: what a translator has in its hands when it asks the layout. + /// + static let memberReadBy (reading : Expr) : DocumentMember = + match reading with + | Lambda (_, PropertyGet (Some receiver, property, [])) -> { Holder = receiver.Type; Member = property } + | other -> invalidArg (nameof reading) $"The quotation should read a property of its parameter: %A{other}" + + /// The options of FSharp.SystemTextJson as it is made, with a change. + static let fsharpOptions (configure : JsonSerializerOptions -> unit) : JsonSerializerOptions = + let options = SerializerProfiles.fsharpDefault.Create () + configure options + options + + /// Every type of the model with every way to set the serializer up that the layout supports. + static member SampleRows : IEnumerable> = seq { + for profile in SerializerProfiles.supported do + for sample in StoredSamples.all do + TestDataRow( + struct (profile, sample), + DisplayName = $"%s{sample.Name} must be laid out as it is written by %s{profile.Name}" + ) + } + + /// Every way to set the serializer up that the layout supports. + static member SupportedRows : IEnumerable> = + SerializerProfiles.supported + |> Seq.map (fun profile -> + TestDataRow(profile, DisplayName = $"the layout must support %s{profile.Name}") + ) + + /// Every way to set the serializer up that the layout refuses. + static member RefusalRows : IEnumerable> = + SerializerProfiles.refused + |> Seq.map (fun refusal -> + TestDataRow(refusal, DisplayName = $"the layout must refuse %s{refusal.Name}") + ) + + [] + member _.``A type must be laid out as the serializer writes it`` (profile : SerializerProfile, sample : StoredSample) = + let found = disagreements profile sample + let listed = String.Join ("\n", found) + + Assert.IsEmpty (found, $"The layout should name every member as the document does.\n%s{listed}") + + [] + member _.``Options that the layout supports must give a layout`` (profile : SerializerProfile) = + match JsonLayout.ofSerializerOptions (profile.Create ()) with + | Result.Ok _ -> () + | Result.Error reasons -> + Assert.Fail $"The layout should support the options, but it refuses them:\n%s{String.Join ('\n', reasons)}" + + [] + member _.``Options that the layout does not support must be refused with the reason`` (refusal : SerializerProfiles.Refusal) = + let reasons = LayoutAssert.WantRefusals (refusal.Create ()) + + Assert.IsTrue ( + reasons + |> Seq.exists (fun reason -> reason.Contains (refusal.Reason, StringComparison.Ordinal)), + $"A reason should say \"%s{refusal.Reason}\", but the reasons are:\n%s{String.Join ('\n', reasons)}" + ) + + [] + member _.``A set-up with one setting that is not supported must be refused for that setting only`` () = + let refusal = + SerializerProfiles.refused + |> Seq.find (fun refusal -> refusal.Name.Contains ("tuples", StringComparison.Ordinal)) + + let reasons = LayoutAssert.WantRefusals (refusal.Create ()) + + Assert.HasCount (1, reasons, $"Only the setting of the options that is not supported should be named: %A{reasons}") + + [] + member _.``A set-up with several settings that are not supported must be refused for each of them`` () = + // Nothing is left to find out one at a time. + let options = JsonSerializerOptions (ReferenceHandler = ReferenceHandler.Preserve) + options.NumberHandling <- JsonNumberHandling.WriteAsString + options.IgnoreReadOnlyProperties <- true + options.IgnoreReadOnlyFields <- true + + let reasons = LayoutAssert.WantRefusals options + + Assert.HasCount ( + 5, + reasons, + $"The layout should name every setting that it does not support:\n%s{String.Join ('\n', reasons)}" + ) + + [] + member _.``The model must be found in its documents member by member`` () = + // The test above compares the layout with what it finds in a document. This one checks that it finds + // something: a search that found nothing would agree with a layout that says nothing. + let document = + JsonSerializer.SerializeToElement ( + StoredSamples.entry.Value, + typeof, + SerializerProfiles.fsharpDefault.Create () + ) + + Assert.AreEqual(ValueSome "Title", propertyHolding "title-1" document, "A text is found by its value.") + Assert.AreEqual(ValueSome "Count", propertyHolding 31 document, "A number is found by its value.") + + Assert.AreEqual( + ValueSome "Choice", + propertyHolding 32 document, + "The value of an option is found where the option is written as its value." + ) + + Assert.AreEqual( + ValueNone, + propertyHolding "draft-1" document, + "A field that is never written is not found." + ) + + [] + member _.``A member that is never written must have the name it declares`` () = + let layout = layoutOf SerializerProfiles.fsharpDefault + + Assert.AreEqual( + ValueSome "$type", + layout.MemberName (propertyOf typeof "Discriminator"), + "A property of a class that declares its name stands for a property that something else writes." + ) + + Assert.AreEqual( + ValueSome "$type", + layout.MemberName (propertyOf typeof "Discriminator"), + "So does a field of a record." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Secret"), + "A property that is never written and declares no name is in no document." + ) + + [] + member _.``A member that a derived class overrides must have the name of each declaration`` () = + let options = SerializerProfiles.fsharpDefault.Create () + let layout = LayoutAssert.WantLayout options + + let document = + JsonSerializer.SerializeToElement (StoredSamples.person.Value, typeof, options) + + Assert.AreEqual( + ValueSome "pk", + layout.MemberName (propertyOf typeof "Tenant"), + "The declaration of the base class declares the name." + ) + + Assert.AreEqual( + ValueSome "Tenant", + layout.MemberName (propertyOf typeof "Tenant"), + "The override declares none, and the serializer does not take the name of the base class for it." + ) + + Assert.AreEqual( + "tenant of id-1", + document.GetProperty("pk").GetString(), + "The document holds the value under the declared name." + ) + + Assert.AreEqual( + "tenant of id-1", + document.GetProperty("Tenant").GetString(), + "It holds it under the name of the override too." + ) + + [] + member _.``A member of a base class must have one name whichever class it is asked through`` () = + let layout = layoutOf SerializerProfiles.fsharpDefault + + Assert.AreEqual( + layout.MemberName (propertyOf typeof "Note"), + layout.MemberName (propertyOf typeof "Note"), + "Reflection gives the same property through the derived class, with another reflected type." + ) + + Assert.AreEqual( + ValueSome "Note", + layout.MemberName (propertyOf typeof "Note"), + "It is named by the policy." + ) + + [] + member _.``The property that holds what no member stands for must have no name`` () = + Assert.AreEqual( + ValueNone, + (layoutOf SerializerProfiles.fsharpDefault).MemberName(propertyOf typeof "Extra"), + "Its entries are written as properties of the document itself, and it is not." + ) + + [] + member _.``A member of a record that is not written must be laid out as one that something else writes`` () = + let options = SerializerProfiles.fsharpDefault.Create () + let layout = LayoutAssert.WantLayout options + + let written = + JsonSerializer.SerializeToElement (StoredSamples.entry.Value, typeof, options) + + for writtenName in + seq { + "Summary" + "Initial" + "first_letter" + "Whisper" + } do + Assert.IsFalse ( + fst (written.TryGetProperty writtenName), + $"FSharp.SystemTextJson should write no property %s{writtenName}: its member is no field and is not included." + ) + + Assert.AreEqual( + ValueSome "first_letter", + layout.MemberName (propertyOf typeof "Initial"), + "A member that is never written has the name it declares." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Summary"), + "And no name when it declares none." + ) + + [] + member _.``A member of a type that the serializer refuses must have no name`` () = + Assert.AreEqual( + ValueNone, + (layoutOf SerializerProfiles.fsharpDefault).MemberName(propertyOf typeof "Id"), + "The serializer writes no value of the type, so no document holds a member of it." + ) + + [] + member _.``A type that the serializer has no contract for must not be described`` () = + // The serializer refuses a ref struct, and a type that the resolver of the application has no contract for. + let refStruct = nonNull (Type.GetType "System.TypedReference") + + Assert.AreEqual( + PolymorphismEncoding.NotDescribed, + (layoutOf SerializerProfiles.fsharpDefault).Polymorphism refStruct, + "The serializer makes no contract of a ref struct." + ) + + let bare = SerializerProfiles.fsharpDefault.Create () + bare.TypeInfoResolver <- StoredBareResolver () + let layout = LayoutAssert.WantLayout bare + + Assert.Throws( + Action (fun () -> + JsonSerializer.Serialize (StoredSamples.person.Value, typeof, bare) + |> ignore + ), + "The serializer should refuse a type that the resolver has no contract for, or the test checks nothing." + ) + |> ignore + + Assert.AreEqual( + PolymorphismEncoding.NotDescribed, + layout.Polymorphism typeof, + "The serializer has no contract of the type, so nothing is known about it." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Name"), + "So no document holds a member of it." + ) + + [] + member _.``A member with a converter of its own must have its name`` () = + let options = SerializerProfiles.fsharpDefault.Create () + let layout = LayoutAssert.WantLayout options + + let written = JsonSerializer.SerializeToElement (StoredMeeting (Topic = "topic-1"), options) + + Assert.AreEqual("topic-1", written.GetProperty("Topic").GetString() |> nonNull, "The member should be written.") + + Assert.AreEqual( + ValueSome "Topic", + layout.MemberName (propertyOf typeof "Topic"), + "The converter of the member decides what is written under the name, and not the name." + ) + + [] + member _.``A member of a type that another converter writes must have no name`` () = + let options = SerializerProfiles.fsharpDefault.Create () + options.Converters.Insert (0, StoredPointAsTextConverter ()) + let layout = LayoutAssert.WantLayout options + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "X"), + "The converter writes the point as a text, which has no members, also when the field declares a name." + ) + + [] + member _.``A member of a type that is no object and no record must have no name`` () = + let layout = layoutOf SerializerProfiles.fsharpDefault + + for struct (holder, name) in + seq { + struct (typeof, "Tag") + struct (typeof, "Length") + struct (typeof, "Value") + } do + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf holder name), + $"%s{holder.Name} is written by a converter of FSharp.SystemTextJson as a union or a list, and its property %s{name} is in no document." + ) + + [] + member _.``A record whose representation is private must be laid out as the serializer writes it`` () = + let options = SerializerProfiles.fsharpDefault.Create () + let layout = LayoutAssert.WantLayout options + + Assert.AreEqual( + "{\"Code\":\"key-1\"}", + JsonSerializer.Serialize (StoredKey.Of "key-1", options), + "The library should write the field of the record, whatever its accessibility, or the test checks nothing." + ) + + Assert.AreEqual( + ValueSome "Code", + layout.MemberName (propertyOf typeof "Code"), + "The field is written under its name, although the representation of the record is private." + ) + + [] + member _.``A record whose members are written under one name must not be described`` () = + let camel = fsharpOptions (fun options -> options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase) + let plain = SerializerProfiles.fsharpDefault.Create () + let layoutPlain = LayoutAssert.WantLayout plain + let layoutCamel = LayoutAssert.WantLayout camel + + // The library writes both members, and a document holds the property twice. + Assert.AreEqual( + "{\"title\":\"a\",\"title\":\"b\"}", + JsonSerializer.Serialize (({ Title = "a"; title = "b" } : StoredTwin), camel), + "The policy should make one name of two, or the test checks nothing." + ) + + Assert.AreEqual( + "{\"same\":1,\"same\":2}", + JsonSerializer.Serialize (({ First = 1; Second = 2 } : StoredNamedTwice), plain), + "Two declared names should be one, or the test checks nothing." + ) + + Assert.AreEqual( + "{\"Total\":4,\"Total\":5}", + JsonSerializer.Serialize (({ Total = 4 } : StoredClash), plain), + "A property that asks to be written should have the name of a field, or the test checks nothing." + ) + + for struct (holder, name, layout) in + seq { + struct (typeof, "Title", layoutCamel) + struct (typeof, "title", layoutCamel) + struct (typeof, "First", layoutPlain) + struct (typeof, "Second", layoutPlain) + struct (typeof, "Total", layoutPlain) + struct (typeof, "Sum", layoutPlain) + } do + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf holder name), + $"A query cannot tell which of two properties of one name it reads, so %s{holder.Name}.%s{name} has no name." + ) + + // Names that differ are told apart, also when they differ by the case of a letter only. + Assert.AreEqual( + ValueSome "Title", + layoutPlain.MemberName (propertyOf typeof "Title"), + "Without a policy the first field is named as it is." + ) + + Assert.AreEqual( + ValueSome "title", + layoutPlain.MemberName (propertyOf typeof "title"), + "And so is the second one: a property name is compared exactly." + ) + + [] + member _.``A member that is never written must not make the name of another one collide`` () = + let options = SerializerProfiles.fsharpDefault.Create () + let layout = LayoutAssert.WantLayout options + + Assert.AreEqual( + "{\"Visible\":1}", + JsonSerializer.Serialize (({ Visible = 1; Hidden = 2 } : StoredHidden), options), + "The library should write the first field only, or the test checks nothing." + ) + + Assert.AreEqual( + ValueSome "Visible", + layout.MemberName (propertyOf typeof "Visible"), + "The property is written once, so the record is described." + ) + + Assert.AreEqual( + ValueSome "Visible", + layout.MemberName (propertyOf typeof "Hidden"), + "A member that is never written has the name it declares." + ) + + [] + member _.``A member that an override never writes must have no name when the override declares none`` () = + let layout = layoutOf SerializerProfiles.fsharpDefault + + Assert.AreEqual( + ValueSome "$tag", + layout.MemberName (propertyOf typeof "Tag"), + "The declaration of the base class declares the name of a property that something else writes." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Tag"), + "The override declares none, and the serializer does not take the name of the base class for it." + ) + + [] + member _.``A member that a quotation reads must be laid out as the type it is read from is written`` () = + let inherited = memberReadBy <@ fun (talk : StoredTalk) -> talk.Room @> + + Assert.AreEqual( + typeof, + inherited.Member.ReflectedType, + "A quotation names an inherited property as the class that declares it has it, so the member does not tell which type it is read from." + ) + + Assert.AreEqual( + ValueSome "Room", + (layoutOf SerializerProfiles.fsharpDefault).MemberName inherited, + "The serializer writes the derived class as an object, with the property that it inherits." + ) + + let options = SerializerProfiles.fsharpDefault.Create () + options.Converters.Add (StoredTalkAsTextConverter ()) + let layout = LayoutAssert.WantLayout options + + Assert.AreEqual( + ValueSome "Room", + layout.MemberName (memberReadBy <@ fun (meeting : StoredMeeting) -> meeting.Room @>), + "The serializer still writes the class that declares the member as an object." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName inherited, + "A converter writes the class that inherits the member as a text, which has no members." + ) + + [] + member _.``A member that a derived class overrides must be laid out as the override when it is read from that class`` () = + let layout = layoutOf SerializerProfiles.fsharpDefault + + // The declaration of the base class, read from a value of the derived class: a quotation that code builds can + // name a property this way. + let declared (name : string) : DocumentMember = { + propertyOf typeof name with + Holder = typeof + } + + Assert.AreEqual( + ValueSome "pk", + layout.MemberName (declared "Tenant"), + "The document of the derived class holds the declaration of the base class too, under the name that it declares." + ) + + Assert.AreEqual( + ValueSome "Remark", + layout.MemberName (declared "Remark"), + "The document holds this property once, as the override, so the override is what the layout describes." + ) + + // A quotation that the compiler stores names the override itself. + let quoted = memberReadBy <@ fun (person : StoredPerson) -> person.Remark @> + + Assert.AreEqual( + typeof, + quoted.Member.DeclaringType, + "The quotation of compiled code names the property as the derived class declares it." + ) + + Assert.AreEqual(ValueSome "Remark", layout.MemberName quoted, "The override is named the same way.") + + [] + member _.``A record that names a converter in an attribute must be described when a converter of the options writes it`` () = + // The serializer asks the converters of the options before the attribute of a type. + let options = SerializerProfiles.fsharpDefault.Create () + let layout = LayoutAssert.WantLayout options + + Assert.AreEqual( + """{"From":3,"To":5,"Note":null}""", + JsonSerializer.Serialize ({ From = 3; To = 5; Note = None }, options), + "The converter of the options should write the record, or the test checks nothing." + ) + + Assert.AreEqual( + ValueSome "From", + layout.MemberName (propertyOf typeof "From"), + "FSharp.SystemTextJson writes the record, whatever converter the record names." + ) + + [] + member _.``A record whose converter stands among the options by itself must not be described`` () = + // The converter is made with options of its own, which nothing lets a layout read. + let options = SerializerProfiles.fsharpDefault.Create () + + options.Converters.Insert ( + 0, + JsonRecordConverter>( + options, + JsonFSharpOptions.Default().WithSkippableOptionFields SkippableOptionFields.Always + ) + ) + + let layout = LayoutAssert.WantLayout options + + Assert.AreEqual( + """{"Item":72}""", + JsonSerializer.Serialize (({ Item = 72; Label = None } : StoredBox), options), + "The converter should write the record with its own options, or the test checks nothing." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof> "Label"), + "The rules of the converter are not known, so the layout should not guess the name." + ) + + Assert.AreEqual( + ValueSome "Name", + layout.MemberName (propertyOf typeof "Name"), + "A record that the converter of FSharp.SystemTextJson writes is still described." + ) + + [] + member _.``A record that has options of its own must not be described`` () = + let options = + (JsonFSharpOptions + .Default() + .WithAllowOverride() + .WithOverrides(fun common -> + let overrides = Dictionary() + overrides.Add (typeof, common.WithSkippableOptionFields SkippableOptionFields.Never) + // For every type that is made of the generic record. + overrides.Add (typedefof>, common.WithSkippableOptionFields SkippableOptionFields.Never) + overrides :> IDictionary + )) + .ToJsonSerializerOptions() + + let layout = LayoutAssert.WantLayout options + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Name"), + "The options of the type are its own, which are not the common ones that the layout reads." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof> "Item"), + "The options are given for every type that is made of the generic record." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Text"), + "The attribute of the record gives it options, when the common options let an attribute do that." + ) + + Assert.AreEqual( + ValueSome "Title", + layout.MemberName (propertyOf typeof "Title"), + "A record that has none is described." + ) + + let ignoring = layoutOf SerializerProfiles.fsharpDefault + + Assert.AreEqual( + ValueSome "Text", + ignoring.MemberName (propertyOf typeof "Text"), + "Where the common options do not let an attribute give options, the attribute is not read, and the record is written with the common options." + ) + + [] + member _.``A record whose contract a resolver of the caller makes must not be described`` () = + let author : StoredAuthor = { Name = "name-1" } + let name = propertyOf typeof "Name" + + // The converter of FSharp.SystemTextJson for a record, made with options that nothing shows. + let quiet () : JsonConverter = + JsonRecordConverter( + JsonSerializerOptions (PropertyNamingPolicy = JsonNamingPolicy.SnakeCaseLower), + JsonFSharpOptions.Default().WithSkippableOptionFields SkippableOptionFields.Always + ) + + let options = SerializerProfiles.fsharpDefault.Create () + + options.TypeInfoResolver <- + StoredContractResolver(fun options -> + JsonMetadataServices.CreateValueInfo(options, quiet ()) + ) + + let layout = LayoutAssert.WantLayout options + + Assert.AreEqual( + "{\"name\":\"name-1\"}", + JsonSerializer.Serialize (author, options), + "The resolver should have the record written with the converter of FSharp.SystemTextJson and names in snake case, which the converter among the options does not say, or the test checks nothing." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName name, + "The serializer did not make the contract of the record, so the converter among the options does not tell how the record is written." + ) + + // The same resolver leaves every other type to the serializer, as a resolver does that an application derives + // from the one of the serializer to change some contracts. + let passing = SerializerProfiles.fsharpDefault.Create () + + passing.TypeInfoResolver <- + StoredContractResolver>(fun options -> + JsonMetadataServices.CreateValueInfo>( + options, + JsonRecordConverter>(options, JsonFSharpOptions.Default ()) + ) + ) + + Assert.AreEqual( + ValueSome "Name", + (LayoutAssert.WantLayout passing).MemberName name, + "The serializer made the contract of the record, also as the class that the application derives from its resolver, so the converter among the options tells how the record is written." + ) + + [] + member _.``A layout must ask the serializer about a member once`` () = + let options = SerializerProfiles.fsharpDefault.Create () + options.PropertyNamingPolicy <- StoredCountingNamingPolicy() + let layout = LayoutAssert.WantLayout options + let title = propertyOf typeof "Title" + let first = layout.MemberName title + let spelledForFirst = StoredCountingNamingPolicy.Spelled + let second = layout.MemberName title + + Assert.AreEqual(ValueSome "Title", first, "The record should be written under the name of its field.") + Assert.AreEqual(first, second, "The answer is the same every time.") + + Assert.AreEqual( + spelledForFirst, + StoredCountingNamingPolicy.Spelled, + "The layout has the policy spell the name to find the answer, and remembers the answer: the policy spelled nothing for the second one." + ) + + [] + member _.``A layout must ask the serializer about a member once when several threads ask at a time`` () : Task = task { + let makeLayout () = + let options = SerializerProfiles.fsharpDefault.Create () + options.PropertyNamingPolicy <- StoredGatedNamingPolicy () + LayoutAssert.WantLayout options + + let title = propertyOf typeof "Title" + + // What one thread spells to find the answer, while the gate is open. + let alone = makeLayout () + let spelledBefore = StoredGatedNamingPolicy.Spelled + alone.MemberName title |> ignore + let spelledForOne = StoredGatedNamingPolicy.Spelled - spelledBefore + + let layout = makeLayout () + let spelledBeforeAll = StoredGatedNamingPolicy.Spelled + StoredGatedNamingPolicy.Gate.Reset () + + // Each asks on a thread of its own: the pool is busy with the other tests, and it would start them late. + let asking = + Array.init 4 (fun _ -> Task.Factory.StartNew ((fun () -> layout.MemberName title), TaskCreationOptions.LongRunning)) + + // The first thread waits inside the policy. The others get the time to come there too, which they would do if + // every thread worked the answer out for itself. + let entered = + SpinWait.SpinUntil ((fun () -> StoredGatedNamingPolicy.Spelled > spelledBeforeAll), TimeSpan.FromSeconds 10.0) + + do! Task.Delay 200 + StoredGatedNamingPolicy.Gate.Set () + let! names = Task.WhenAll asking + + Assert.IsTrue (entered, "A thread should have asked the policy to spell the name.") + + Assert.AreEqual( + spelledForOne, + StoredGatedNamingPolicy.Spelled - spelledBeforeAll, + "One thread works the answer out, and the others wait for it: the policy spelled as much as for one thread." + ) + + Assert.IsTrue (names |> Array.forall (fun name -> name = ValueSome "Title"), "Every thread should get the answer.") + } + + [] + member _.``The layout must leave the options it is made of as they are, and not follow a later change of them`` () = + let options = SerializerProfiles.fsharpDefault.Create () + let layout = LayoutAssert.WantLayout options + let comment = propertyOf typeof "Comment" + + Assert.IsFalse (options.IsReadOnly, "The caller may still have to finish the options.") + Assert.IsNull (options.TypeInfoResolver, "The layout should give the options of the caller no resolver.") + + options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase + + Assert.AreEqual( + ValueSome "Comment", + layout.MemberName comment, + "A change of the options after the layout is made does not reach it, also for a member that it is asked about for the first time." + ) + + Assert.AreEqual( + ValueSome "comment", + (LayoutAssert.WantLayout options).MemberName comment, + "A layout that is made after the change has it." + ) + + [] + member _.``The layout must ask the resolver that the options have, and leave it and the options as they are`` () = + // The resolver gives one property another name, which no attribute and no policy says. + let resolver = + DefaultJsonTypeInfoResolver() + .WithAddedModifier(fun (info : JsonTypeInfo) -> + for property in info.Properties do + if + Type.(=) (info.Type, typeof) + && String.Equals (property.Name, "Note", StringComparison.Ordinal) + then + property.Name <- "remark" + ) + + let options = fsharpOptions (fun options -> options.TypeInfoResolver <- resolver) + let layout = LayoutAssert.WantLayout options + + Assert.AreEqual( + ValueSome "remark", + layout.MemberName (propertyOf typeof "Note"), + "The layout should give the name that the resolver of the caller gives, as the serializer does." + ) + + Assert.IsFalse (options.IsReadOnly, "The caller may still have to finish the options.") + + Assert.AreSame( + resolver, + options.TypeInfoResolver, + "The options of the caller should keep the resolver they were given." + ) + + [] + member _.``The resolver that the layout shares with the serializer must take no change once the layout has asked it`` () = + // A resolver cannot be copied, so the layout asks the one that the serializer asks. + let rename = + Action(fun info -> + if Type.(=) (info.Type, typeof) then + for property in info.Properties do + if String.Equals (property.Name, "Note", StringComparison.Ordinal) then + property.Name <- "remark" + ) + + let resolver = DefaultJsonTypeInfoResolver () + let options = fsharpOptions (fun options -> options.TypeInfoResolver <- resolver) + let layout = LayoutAssert.WantLayout options + + resolver.Modifiers.Add rename + + Assert.AreEqual( + ValueSome "remark", + layout.MemberName (propertyOf typeof "Note"), + "A change of the resolver before the layout is asked should reach the layout, as it reaches the serializer." + ) + + Assert.Throws( + Action (fun () -> resolver.Modifiers.Add rename), + "The resolver should take no change after the layout has asked it: a change that reached only the serializer would go unnoticed." + ) + |> ignore + + let written = + JsonSerializer.SerializeToElement (StoredSamples.person.Value, typeof, options) + + Assert.IsTrue ( + fst (written.TryGetProperty "remark"), + "The serializer should write the name that the layout gives: both asked one resolver." + ) diff --git a/tests/Cosmos.Quotations.Tests/JsonLayoutUnionTests.fs b/tests/Cosmos.Quotations.Tests/JsonLayoutUnionTests.fs new file mode 100644 index 00000000..16d2d2e5 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/JsonLayoutUnionTests.fs @@ -0,0 +1,601 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open System.Reflection +open System.Text.Json +open System.Text.Json.Serialization +open System.Text.Json.Serialization.Metadata +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Reflection + +open FSharp.Azure.Cosmos +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// +/// What says about unions, compared with what the +/// serializer writes for them. A value of every case of the model of unions is written with every way to set the +/// serializer up that the layout supports. The document has to hold the mark that the layout gives the case, and no +/// mark of another case, and the value of every field at the place that the layout gives it. +/// +[] +type JsonLayoutUnionTests () = + + /// The cases of a union that a layout describes although it should describe none, as texts for a failure message. + static let describedCasesOf + (layout : IJsonLayout) + (memberOfDocument : DocumentMember voption) + (unionType : Type) + (reason : string) + : string seq = seq { + for case in FSharpType.GetUnionCases (unionType, true) do + if not (layout.UnionCaseEncoding (memberOfDocument, case)).IsNotDescribed then + $"%s{unionType.Name}.%s{case.Name}: %s{reason}, and the layout describes the case" + } + + /// + /// Everything the layout says about the unions of the model that a way to set the serializer up does not confirm, + /// when each value is written by itself; empty when the layout is right. + /// + static let disagreementsAlone (profile : SerializerProfile) : string array = + let options = profile.Create () + let layout = LayoutAssert.WantLayout options + + seq { + for sample in StoredUnionSamples.all do + match WrittenUnions.writtenAll options sample.UnionType sample.Values with + | ValueSome documents -> + for struct (value, document) in documents do + yield! WrittenUnions.disagreementsAbout layout options ValueNone sample.UnionType value document + | ValueNone -> yield! describedCasesOf layout ValueNone sample.UnionType "the serializer refuses the union" + } + |> Seq.toArray + + /// + /// The same for the values as a member of a record holds them: the layout is asked about the member, and the + /// value is looked for under the name that the layout gives the member. + /// + static let disagreementsHeld (profile : SerializerProfile) : string array = + let options = profile.Create () + let layout = LayoutAssert.WantLayout options + + seq { + for sample in StoredUnionSamples.all do + let holderType = typedefof>.MakeGenericType sample.UnionType + + let held = { + Holder = holderType + Member = nonNull (holderType.GetProperty (nameof Unchecked.defaultof>.Held)) + } + + let holders = + sample.Values + |> Seq.map (fun value -> FSharpValue.MakeRecord (holderType, [| value |], true)) + |> Seq.cast + + match WrittenUnions.writtenAll options holderType holders, layout.MemberName held with + | ValueSome documents, ValueSome name -> + for struct (holder, document) in documents do + let value = held.Member :?> PropertyInfo |> _.GetValue(holder) + + match document.TryGetProperty name with + | true, found -> + yield! WrittenUnions.disagreementsAbout layout options (ValueSome held) sample.UnionType value found + | false, _ -> + let struct (case, _) = WrittenUnions.caseOf sample.UnionType value + $"%s{sample.UnionType.Name}.%s{case.Name}: the document does not hold the member" + | ValueNone, _ -> + yield! describedCasesOf layout (ValueSome held) sample.UnionType "the serializer refuses the union" + | _, ValueNone -> + yield! describedCasesOf layout (ValueSome held) sample.UnionType "the serializer never writes the member" + } + |> Seq.toArray + + /// What a layout says of a case, as a text that two answers with the same steps share. + static let described (encoding : UnionCaseEncoding) : string = + match encoding with + | UnionCaseEncoding.NotDescribed -> "not described" + | UnionCaseEncoding.Written (mark, places) -> + let markShown = + match mark with + | UnionCaseMark.Tag (path, tag) -> $"tag %s{tag} at value%s{WrittenSteps.shown path}" + | UnionCaseMark.Unmarked -> "unmarked" + + let placesShown = + places + |> Seq.map (fun place -> + match place with + | UnionFieldPlace.Value path -> $"value%s{WrittenSteps.shown path}" + | UnionFieldPlace.Members path -> $"members of value%s{WrittenSteps.shown path}" + ) + |> String.concat ", " + + $"%s{markShown}; fields: %s{placesShown}" + + /// The layout of FSharp.SystemTextJson with options, as a change of the common options. + static let layoutOf (configure : JsonFSharpOptions -> JsonFSharpOptions) : struct (JsonSerializerOptions * IJsonLayout) = + let options = (configure (JsonFSharpOptions.Default ())).ToJsonSerializerOptions() + struct (options, LayoutAssert.WantLayout options) + + /// Every way to have the name of the tag written twice, as a row of a data-driven test. + static member TagTwiceRows : IEnumerable> = + StoredUnionSamples.tagsTwice + |> Seq.map (fun twice -> + TestDataRow(twice, DisplayName = $"a union must not be described when %s{twice.Reason}") + ) + + /// Every way to set the serializer up that the layout supports. + static member ProfileRows : IEnumerable> = + SerializerProfiles.supported + |> Seq.map (fun profile -> + TestDataRow( + profile, + DisplayName = $"the unions must be laid out as they are written by %s{profile.Name}" + ) + ) + + /// Every union that the layout does not describe. + static member NotDescribedRows : IEnumerable> = + StoredUnionSamples.notDescribed + |> Seq.map (fun (struct (reason, unionType)) -> + TestDataRow( + struct (reason, unionType), + DisplayName = $"a union must not be described when %s{reason}" + ) + ) + + [] + member _.``The cases of a union must be laid out as the serializer writes them`` (profile : SerializerProfile) = + let found = disagreementsAlone profile + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"The layout should give every case a mark that the document of a value of the case has and the document of no other case, and every field the place of its value.\n%s{listed}" + ) + + [] + member _.``The cases of a union that a member holds must be laid out as the serializer writes them`` + (profile : SerializerProfile) + = + let found = disagreementsHeld profile + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"The layout should say of a union in a member what it says of the union alone, and nothing of a member that is not written.\n%s{listed}" + ) + + [] + member _.``The model of unions must be written in every way that the layout describes`` () = + // The tests above compare the layout with the documents they find. This one checks that the documents are of + // every kind: a model that the serializer wrote one way only would agree with a layout that knows one way. + let said = + SerializerProfiles.supported + |> Seq.collect (fun profile -> + let layout = LayoutAssert.WantLayout (profile.Create ()) + + seq { + for sample in StoredUnionSamples.all do + for case in FSharpType.GetUnionCases (sample.UnionType, true) do + match layout.UnionCaseEncoding (ValueNone, case) with + | UnionCaseEncoding.Written (mark, places) -> + match mark with + | UnionCaseMark.Tag (path, _) -> + let steps = + path + |> Seq.map (fun step -> if step.IsProperty then "property" else "item") + |> String.concat ", " + + $"mark: a tag at [%s{steps}]" + | UnionCaseMark.Unmarked -> "mark: none" + + for place in places do + match place with + | UnionFieldPlace.Value path -> + let steps = + path + |> Seq.map (fun step -> if step.IsProperty then "property" else "item") + |> String.concat ", " + + $"field: a value at [%s{steps}]" + | UnionFieldPlace.Members path -> $"field: members at a path of %d{path.Length}" + | UnionCaseEncoding.NotDescribed -> "not described" + } + ) + |> Seq.distinct + |> Seq.sort + |> Seq.toArray + + CollectionAssert.AreEqual ( + [| + "field: a value at []" + "field: a value at [item]" + "field: a value at [property, item]" + "field: a value at [property, property]" + "field: a value at [property]" + "field: members at a path of 0" + "mark: a tag at []" + "mark: a tag at [item]" + "mark: a tag at [property]" + "mark: none" + |], + said, + $"The ways to set the serializer up should have the model written with every kind of mark and with a field at every kind of place: %A{said}" + ) + + [] + member _.``A union that the layout does not support must not be described`` (reason : string, unionType : Type) = + for profile in + seq { + SerializerProfiles.fsharpDefault + SerializerProfiles.production + } do + let found = + describedCasesOf (LayoutAssert.WantLayout (profile.Create ())) ValueNone unionType reason + |> Seq.toArray + + let listed = String.Join ("\n", found) + + Assert.IsEmpty (found, $"A union is described as a whole, and no case of this one is (%s{profile.Name}).\n%s{listed}") + + [] + member _.``A union with a case that declares the name of a field must be one that the serializer writes`` () = + // The test above would pass for a union that the serializer cannot write at all. This one checks the union. + let options = (JsonFSharpOptions.Default().WithUnionNamedFields()).ToJsonSerializerOptions() + + Assert.AreEqual( + "{\"Case\":\"Pair\",\"Fields\":{\"first\":1,\"Item2\":2}}", + JsonSerializer.Serialize (Pair (1, 2), options), + "The serializer should write the field under the name that the case declares for it, or the test checks nothing." + ) + + [] + member _.``A union that the serializer refuses must not be described`` () = + let options = SerializerProfiles.fsharpDefault.Create () + let layout = LayoutAssert.WantLayout options + + Assert.Throws( + Action (fun () -> JsonSerializer.Serialize (Plain, options) |> ignore), + "FSharp.SystemTextJson should refuse a union with a case that has two attributes with names, or the test checks nothing." + ) + |> ignore + + Assert.AreEqual( + "not described", + described (layout.UnionCaseEncoding (ValueNone, WrittenUnions.caseNamed typeof "Plain")), + "No case of a union that the serializer cannot write is described." + ) + + [] + member _.``A union with a case that is written with the name of its tag twice must not be described`` + (twice : StoredTagTwice) + = + let options = twice.Settings.ToJsonSerializerOptions () + options.PropertyNamingPolicy <- twice.PropertyNaming + let layout = LayoutAssert.WantLayout options + use document = JsonDocument.Parse (JsonSerializer.Serialize (twice.Value, options)) + + Assert.HasCount ( + 2, + document.RootElement.EnumerateObject () + |> Seq.where _.NameEquals(twice.TagName), + "FSharp.SystemTextJson should write the name of the tag twice for the case, or the test checks nothing." + ) + + let found = + describedCasesOf layout ValueNone typeof "a case has two properties of the name of the tag" + |> Seq.toArray + + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"A document of that case can hold the tag of another case in its second property, so no case can be told.\n%s{listed}" + ) + + [] + member _.``A union whose cases are written with one tag by a naming policy must not be described`` () = + let struct (options, layout) = layoutOf _.WithUnionTagNamingPolicy(JsonNamingPolicy.SnakeCaseLower) + + Assert.AreEqual( + "{\"Case\":\"foo_bar\"}", + JsonSerializer.Serialize (FooBar, options), + "The policy should give the case a tag that the other case has too, or the test checks nothing." + ) + + Assert.AreEqual( + "{\"Case\":\"foo_bar\",\"Fields\":[3]}", + JsonSerializer.Serialize (Foo_Bar 3, options), + "The other case has that tag." + ) + + let found = + describedCasesOf layout ValueNone typeof "two cases have one tag" + |> Seq.toArray + + let listed = String.Join ("\n", found) + + Assert.IsEmpty (found, $"A document cannot tell the two cases apart, so none is described.\n%s{listed}") + + // Without the policy the tags differ. + let struct (_, plain) = layoutOf id + + Assert.AreEqual( + "tag FooBar at value[\"Case\"]; fields: ", + described (plain.UnionCaseEncoding (ValueNone, WrittenUnions.caseNamed typeof "FooBar")), + "The names of the cases are two tags." + ) + + [] + member _.``A union must not be described when a case writes the members of a record that the layout does not know next to an internal tag`` + () + = + let name = "Name" + + let options = + (JsonFSharpOptions + .Default() + .WithUnionInternalTag() + .WithUnionNamedFields() + .WithUnionUnwrapRecordCases() + .WithUnionTagName + name) + .ToJsonSerializerOptions() + + // A converter of the options writes the record as text, and the union still writes its members. + options.Converters.Insert (0, StoredAsTextConverter()) + let layout = LayoutAssert.WantLayout options + use document = JsonDocument.Parse (JsonSerializer.Serialize (Signed { Name = "signer" }, options)) + + Assert.HasCount ( + 2, + document.RootElement.EnumerateObject () + |> Seq.where _.NameEquals(name), + "The union should write the name of the tag twice, or the test checks nothing." + ) + + let found = + describedCasesOf layout ValueNone typeof "a case holds members whose names are not known" + |> Seq.toArray + + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"One of the members of the record can have the name of the tag, so no case can be told.\n%s{listed}" + ) + + // Next to an adjacent tag the names cannot meet: the other cases are described. + let adjacent = + (JsonFSharpOptions.Default().WithUnionNamedFields().WithUnionUnwrapRecordCases()).ToJsonSerializerOptions() + + adjacent.Converters.Insert (0, StoredAsTextConverter()) + + Assert.AreEqual( + "not described", + described ( + (LayoutAssert.WantLayout adjacent) + .UnionCaseEncoding(ValueNone, WrittenUnions.caseNamed typeof "Signed") + ), + "The case that holds the record is not described, whatever the tag is." + ) + + Assert.IsFalse ( + (LayoutAssert.WantLayout adjacent) + .UnionCaseEncoding(ValueNone, WrittenUnions.caseNamed typeof "Circle") + .IsNotDescribed, + "Another case is described, because the tag has a property of its own." + ) + + [] + member _.``A union of a member with a converter of its own must not be described`` () = + let options = SerializerProfiles.fsharpDefault.Create () + let layout = LayoutAssert.WantLayout options + let circle = WrittenUnions.caseNamed typeof "Circle" + let rect = WrittenUnions.caseNamed typeof "Rect" + + let memberOf (name : string) : DocumentMember voption = + ValueSome { + Holder = typeof + Member = nonNull (typeof.GetProperty name) + } + + let document = + JsonSerializer.SerializeToElement ( + StoredDrawing (Shape = Circle 3, Loud = Rect (4, "rect"), Hidden = Circle 5), + options + ) + + Assert.AreEqual( + "{\"Case\":\"RECT\",\"Fields\":[4,\"rect\"]}", + document.GetProperty("Loud").GetRawText(), + "The converter of the member should write the union with tags in capital letters, which the options do not say, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described (layout.UnionCaseEncoding (memberOf "Loud", rect)), + "Nothing shows the options that the converter of a member writes a union with, also when it is a converter of FSharp.SystemTextJson." + ) + + Assert.AreEqual( + described (layout.UnionCaseEncoding (ValueNone, circle)), + described (layout.UnionCaseEncoding (memberOf "Shape", circle)), + "A member without a converter of its own holds the union as it is written anywhere." + ) + + Assert.AreEqual( + "not described", + described (layout.UnionCaseEncoding (memberOf "Hidden", circle)), + "A member that the serializer never writes is not described: something else writes its property." + ) + + [] + member _.``An option must not be described as a union`` () = + let layout = LayoutAssert.WantLayout (SerializerProfiles.fsharpDefault.Create ()) + + for name in + seq { + "Some" + "None" + } do + Assert.AreEqual( + "not described", + described (layout.UnionCaseEncoding (ValueNone, WrittenUnions.caseNamed typeof name)), + $"An option is written as its value, and a layout says nothing of it as a union (%s{name})." + ) + + [] + member _.``A union that has options of its own must not be described`` () = + // The options of the attribute are the union's own when the common options let an attribute give them. + let struct (options, layout) = layoutOf _.WithAllowOverride() + let stamped = WrittenUnions.caseNamed typeof "Stamped" + let labelled = WrittenUnions.caseNamed typeof "Labelled" + + Assert.AreEqual( + "{\"Stamped\":{\"text\":\"stamp\",\"size\":13}}", + JsonSerializer.Serialize (Stamped ("stamp", 13), options), + "The serializer should write the union with the options of the attribute, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described (layout.UnionCaseEncoding (ValueNone, stamped)), + "The options of the attribute are not the common ones that the layout reads." + ) + + Assert.AreEqual( + "not described", + described (layout.UnionCaseEncoding (ValueNone, labelled)), + "A part of the encoding in an attribute makes the options of the union its own as well." + ) + + // The options of the union are given in the overrides. + let struct (_, overridden) = + layoutOf (fun common -> + common.WithOverrides (fun _ -> + let overrides = Dictionary() + overrides.Add (typeof, common.WithUnionExternalTag ()) + // For every type that is made of the generic union. + overrides.Add (typedefof>, common.WithUnionExternalTag ()) + overrides :> IDictionary + ) + ) + + Assert.AreEqual( + "not described", + described (overridden.UnionCaseEncoding (ValueNone, WrittenUnions.caseNamed typeof "Circle")), + "The options in the overrides are the union's own." + ) + + Assert.AreEqual( + "not described", + described (overridden.UnionCaseEncoding (ValueNone, WrittenUnions.caseNamed typeof> "Fine")), + "The options are given for every type that is made of the generic union." + ) + + Assert.AreEqual( + "tag Front at value[\"Case\"]; fields: ", + described (overridden.UnionCaseEncoding (ValueNone, WrittenUnions.caseNamed typeof "Front")), + "A union that has none is described." + ) + + [] + member _.``A record in a case must not be described when it is not written as the record is by itself`` () = + let signed = WrittenUnions.caseNamed typeof "Signed" + let dealt = WrittenUnions.caseNamed typeof "Dealt" + let undealt = WrittenUnions.caseNamed typeof "Undealt" + + // A converter of the options writes the record as text, so what the layout says of its members is not about + // the record in the case, whose members the union writes itself. + let asText = (JsonFSharpOptions.Default().WithUnionUnwrapRecordCases()).ToJsonSerializerOptions() + asText.Converters.Insert (0, StoredAsTextConverter()) + + Assert.AreEqual( + "{\"Case\":\"Signed\",\"Fields\":{\"Name\":\"signer\"}}", + JsonSerializer.Serialize (Signed { Name = "signer" }, asText), + "The union should write the members of the record in place of the fields, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described ((LayoutAssert.WantLayout asText).UnionCaseEncoding(ValueNone, signed)), + "The record by itself is written by another converter." + ) + + // The record has options of its own in an attribute, which the common options let it have. + let struct (ofAttribute, withAttribute) = + layoutOf (fun common -> common.WithAllowOverride().WithUnionUnwrapRecordCases()) + + Assert.AreEqual( + "{\"Case\":\"Dealt\",\"Fields\":{\"SignedAs\":\"signer\",\"Alias\":null}}", + JsonSerializer.Serialize (Dealt { SignedAs = "signer"; Alias = None }, ofAttribute), + "The union should write the members of the record with its own options, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described (withAttribute.UnionCaseEncoding (ValueNone, dealt)), + "The record is written by itself with the options of its attribute, which are not the ones that the layout describes it with." + ) + + Assert.AreEqual( + "tag Undealt at value[\"Case\"]; fields: ", + described (withAttribute.UnionCaseEncoding (ValueNone, undealt)), + "A case without such a record is described." + ) + + [] + member _.``A union whose contract a resolver of the caller makes must not be described`` () = + let front = WrittenUnions.caseNamed typeof "Front" + + // The resolver makes the contract from the converter of FSharp.SystemTextJson for the union, which it has made + // with a naming policy that the options do not have. + let options = SerializerProfiles.fsharpDefault.Create () + + options.TypeInfoResolver <- + StoredContractResolver(fun options -> + JsonMetadataServices.CreateValueInfo( + options, + nonNull (StoredLoudUnionConverterFactory().CreateConverter(typeof, options)) + ) + ) + + Assert.AreEqual( + "{\"Case\":\"FRONT\"}", + JsonSerializer.Serialize (Front, options), + "The resolver should have the union written with the converter that it made, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described ((LayoutAssert.WantLayout options).UnionCaseEncoding(ValueNone, front)), + "The serializer did not make the contract of the union, so the converter among the options does not tell how the union is written." + ) + + [] + member _.``A layout must work out how a case is written once`` () = + let struct (_, layout) = layoutOf _.WithUnionTagNamingPolicy(StoredCountingNamingPolicy()) + + let front = WrittenUnions.caseNamed typeof "Front" + let first = layout.UnionCaseEncoding (ValueNone, front) + let spelledForFirst = StoredCountingNamingPolicy.Spelled + let second = layout.UnionCaseEncoding (ValueNone, front) + + Assert.AreEqual( + "tag Front at value[\"Case\"]; fields: ", + described first, + "The naming policy of the tags spells the name of the case." + ) + + Assert.AreEqual(described first, described second, "The answer is the same every time.") + Assert.IsGreaterThan (0, spelledForFirst, "The layout has the policy spell the name to find the answer.") + + Assert.AreEqual( + spelledForFirst, + StoredCountingNamingPolicy.Spelled, + "The layout remembers the answer: the policy spelled nothing for the second one." + ) diff --git a/tests/Cosmos.Quotations.Tests/JsonLayoutValueTests.fs b/tests/Cosmos.Quotations.Tests/JsonLayoutValueTests.fs new file mode 100644 index 00000000..ed0d37cb --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/JsonLayoutValueTests.fs @@ -0,0 +1,680 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Reflection +open System.Reflection.Emit +open System.Text.Json +open System.Text.Json.Serialization +open System.Text.Json.Serialization.Metadata +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Reflection + +open FSharp.Azure.Cosmos +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// +/// What says about values that are no objects, compared +/// with what the serializer writes for them: every member of the model of values is written with every way to set the +/// serializer up that the layout supports, and the kind of JSON value that the document holds for it says what the +/// layout should say. +/// +[] +type JsonLayoutValueTests () = + + /// + /// Everything the layout says about the members of a sample that the document of the sample does not confirm; + /// empty when the layout is right. + /// + static let disagreements (profile : SerializerProfile) (sample : StoredValueSample) : string array = + let options = profile.Create () + let layout = LayoutAssert.WantLayout options + let holderType = sample.Value.GetType () + let document = JsonSerializer.SerializeToElement (sample.Value, holderType, options) + + seq { + // Without this a layout that names no member would have nothing to disagree about. + let saidNames = WrittenValues.namesOf layout holderType + let writtenNames = WrittenValues.propertiesOf document + + if saidNames <> writtenNames then + $"The layout names the members %A{saidNames}, the document %A{writtenNames}" + + for dataMember in ModelMembers.ofType holderType do + let memberOfDocument = { Holder = holderType; Member = dataMember } + let memberType = ModelMembers.typeOf dataMember + + // A member that the document does not hold was not written: every member of a sample holds a value + // that no setting leaves out. It has the kind of no JSON value. + let written = + match layout.MemberName memberOfDocument with + | ValueSome name -> + match document.TryGetProperty name with + | true, written -> written + | false, _ -> JsonElement () + | ValueNone -> JsonElement () + + yield! WrittenValues.disagreementsAbout layout dataMember.Name (ValueSome memberOfDocument) memberType written + } + |> Seq.toArray + + /// The kind of JSON value that a way to set the serializer up writes for a member of a sample; none when the + /// document does not hold the member. + static let kindOf (profile : SerializerProfile) (sample : StoredValueSample) (memberName : string) : JsonValueKind = + let options = profile.Create () + let holderType = sample.Value.GetType () + let document = JsonSerializer.SerializeToElement (sample.Value, holderType, options) + let layout = LayoutAssert.WantLayout options + + match layout.MemberName { Holder = holderType; Member = nonNull (holderType.GetProperty memberName) } with + | ValueSome name -> + match document.TryGetProperty name with + | true, written -> written.ValueKind + | false, _ -> JsonValueKind.Undefined + | ValueNone -> JsonValueKind.Undefined + + /// A member of a type, as a layout is asked about it. + static let memberOf (holderType : Type) (name : string) : DocumentMember voption = + ValueSome { Holder = holderType; Member = nonNull (holderType.GetProperty name) } + + /// An enumeration without any value, which no F# source declares. + static let namelessEnumeration (assemblyName : string) : Type = + AssemblyBuilder + .DefineDynamicAssembly(AssemblyName assemblyName, AssemblyBuilderAccess.Run) + .DefineDynamicModule("Enumerations") + .DefineEnum("Nameless", TypeAttributes.Public, typeof) + .CreateType() + + /// The layout of FSharp.SystemTextJson as it is made, with a change of the options. + static let layoutWith (configure : JsonSerializerOptions -> unit) : IJsonLayout = + let options = SerializerProfiles.fsharpDefault.Create () + configure options + LayoutAssert.WantLayout options + + /// Every type of the model of values with every way to set the serializer up that the layout supports. + static member SampleRows : IEnumerable> = seq { + for profile in SerializerProfiles.supported do + for sample in StoredValueSamples.all do + TestDataRow( + struct (profile, sample), + DisplayName = $"the values of %s{sample.Name} must be laid out as they are written by %s{profile.Name}" + ) + } + + /// Every way to set the serializer up that the layout supports. + static member ProfileRows : IEnumerable> = + SerializerProfiles.supported + |> Seq.map (fun profile -> + TestDataRow( + profile, + DisplayName = $"a value that is no member must be laid out as it is written by %s{profile.Name}" + ) + ) + + /// + /// Converters that write the values of an enumeration, some of them in a way of their own, with what the layout + /// should say of the enumeration. The values that have no name are the ones that the converters differ in: zero, + /// the number after the last constant and a combination of two constants, none of which a name stands for. + /// + static member EnumerationRows : IEnumerable> = + let caseOf (enumType : Type) (name : string) (expected : EnumEncoding) (converter : JsonConverter) = { + Name = name + EnumType = enumType + Converter = converter + Expected = expected + } + + let hasName (value : 'Enum) = Enum.IsDefined (typeof<'Enum>, value) + + let cases = [| + caseOf + typeof + "numbers for the values with a name and a text for any other" + EnumEncoding.NotDescribed + (StoredRuleConverter(fun writer value -> + if hasName value then + writer.WriteNumberValue (int value) + else + writer.WriteStringValue "other" + )) + caseOf + typeof + "numbers, and a text for zero only" + EnumEncoding.NotDescribed + (StoredRuleConverter(fun writer value -> + if int value = 0 then + writer.WriteStringValue "none" + else + writer.WriteNumberValue (int value) + )) + caseOf + typeof + "numbers, and a text for the number after the last constant only" + EnumEncoding.NotDescribed + (StoredRuleConverter(fun writer value -> + if int value = 4 then + writer.WriteStringValue "four" + else + writer.WriteNumberValue (int value) + )) + caseOf + typeof + "numbers, and a text for a combination of two constants that is no constant only" + EnumEncoding.NotDescribed + (StoredRuleConverter(fun writer value -> + if int value > 8 then + writer.WriteStringValue "combined" + else + writer.WriteNumberValue (int value) + )) + caseOf + typeof + "names for the values with a name and null for any other" + EnumEncoding.NotDescribed + (StoredRuleConverter(fun writer value -> + if hasName value then + writer.WriteStringValue (string value) + else + writer.WriteNullValue () + )) + caseOf + typeof + "names for the values with a name and numbers for any other" + EnumEncoding.String + (StoredRuleConverter(fun writer value -> + if hasName value then + writer.WriteStringValue (string value) + else + writer.WriteNumberValue (int value) + )) + caseOf + typeof + "numbers for the values with a name and a refusal for any other" + EnumEncoding.Number + (StoredRuleConverter(fun writer value -> + if hasName value then + writer.WriteNumberValue (int value) + else + raise (JsonException "The converter of the test refuses the value.") + )) + caseOf + typeof + "numbers for the values with a name and the exception for an unsupported value for any other" + EnumEncoding.Number + (StoredRuleConverter(fun writer value -> + if hasName value then + writer.WriteNumberValue (int value) + else + raise (NotSupportedException "The converter of the test does not support the value.") + )) + caseOf + typeof + "names and a refusal of any number" + EnumEncoding.String + (JsonStringEnumConverter (null, false)) + caseOf + typeof + "numbers only" + EnumEncoding.Number + (StoredRuleConverter(fun writer value -> writer.WriteNumberValue (int value))) + caseOf + typeof + "numbers only" + EnumEncoding.Number + (StoredRuleConverter(fun writer value -> writer.WriteNumberValue (int value))) + caseOf + typeof + "names, and numbers for any value without one" + EnumEncoding.String + (JsonStringEnumConverter ()) + caseOf + typeof + "names, and numbers for any value without one" + EnumEncoding.String + (JsonStringEnumConverter ()) + |] + + cases + |> Seq.map (fun case -> + TestDataRow( + case, + DisplayName = + $"the enumeration %s{case.EnumType.Name} must be described as %s{string case.Expected} when its converter writes %s{case.Name}" + ) + ) + + [] + member _.``The values of a type must be laid out as the serializer writes them`` + (profile : SerializerProfile, sample : StoredValueSample) + = + let found = disagreements profile sample + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"The layout should say of every member what the kind of its JSON value in the document shows, and nothing of a member that the document does not hold.\n%s{listed}" + ) + + [] + member _.``A value that is no member must be laid out as the serializer writes it`` (profile : SerializerProfile) = + let options = profile.Create () + let layout = LayoutAssert.WantLayout options + + let found = + seq { + for struct (name, value, valueType) in StoredValueSamples.alone do + let written = JsonSerializer.SerializeToElement (value, valueType, options) + yield! WrittenValues.disagreementsAbout layout name ValueNone valueType written + } + |> Seq.toArray + + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"The layout should say of every value what the kind of the JSON value that is written for it shows.\n%s{listed}" + ) + + [] + member _.``The model of values must hold every kind of value in its documents`` () = + // The tests above compare the layout with the kind of JSON value they find. This one checks that they find + // every kind: a model that the serializer wrote one way only would agree with a layout that knows one way. + let catalog = StoredValueSamples.catalog + let entry = StoredValueSamples.entry + let fsharp = SerializerProfiles.fsharpDefault + let byName = SerializerProfiles.named "enumerations by name" + + Assert.AreEqual(JsonValueKind.Number, kindOf fsharp catalog "Colour", "An enumeration is a number.") + + Assert.AreEqual( + JsonValueKind.String, + kindOf byName catalog "Colour", + "With a converter of the options an enumeration is a string." + ) + + Assert.AreEqual( + JsonValueKind.Number, + kindOf fsharp entry "NamedColour", + "FSharp.SystemTextJson does not read the converter that a field of a record names." + ) + + Assert.AreEqual( + JsonValueKind.Array, + kindOf fsharp catalog "Pair", + "FSharp.SystemTextJson writes a tuple as an array." + ) + Assert.AreEqual(JsonValueKind.Array, kindOf fsharp catalog "Names", "A list is an array.") + Assert.AreEqual(JsonValueKind.String, kindOf fsharp catalog "Bytes", "An array of bytes is one string.") + + Assert.AreEqual( + JsonValueKind.Array, + kindOf fsharp catalog "ById", + "FSharp.SystemTextJson writes a map whose keys are no texts as an array of pairs." + ) + + Assert.AreEqual( + JsonValueKind.Object, + kindOf fsharp catalog "Scores", + "FSharp.SystemTextJson writes a map whose keys are texts as an object." + ) + + Assert.AreEqual( + JsonValueKind.Array, + kindOf (SerializerProfiles.named "every map as an array of pairs") catalog "Scores", + "With the setting that writes every map as an array of pairs, a map of texts is an array too." + ) + + Assert.AreEqual( + JsonValueKind.Undefined, + kindOf fsharp entry "OtherColour", + "FSharp.SystemTextJson does not write a property of a record that is no field." + ) + + [] + member _.``A value of another kind must not be described`` () = + let layout = layoutWith ignore + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (ValueNone, typeof), + "A number is no enumeration." + ) + + Assert.AreEqual( + TupleEncoding.NotDescribed, + layout.TupleEncoding (ValueNone, typeof), + "An array is no tuple, although it is written as one can be." + ) + + Assert.AreEqual( + TupleEncoding.NotDescribed, + layout.TupleEncoding (ValueNone, typeof), + "A class is no tuple, although it is written as an object like one." + ) + + for valueType in + seq { + typeof + typeof + typeof + typeof + } do + Assert.AreEqual( + TupleEncoding.NotDescribed, + layout.TupleEncoding (ValueNone, valueType), + $"%s{valueType.Name} is written by a converter of the same library as a tuple is, and is no tuple." + ) + + Assert.AreEqual( + CollectionEncoding.NotDescribed, + layout.CollectionEncoding (ValueNone, typeof), + "A text is no collection of its characters in a document." + ) + + Assert.AreEqual( + CollectionEncoding.NotDescribed, + layout.CollectionEncoding (ValueNone, typeof>), + "A map that is written as an object is no array." + ) + + Assert.AreEqual( + CollectionEncoding.NotDescribed, + layout.CollectionEncoding (ValueNone, typeof>), + "Neither is a dictionary, of which the serializer writes the entries itself." + ) + + Assert.AreEqual( + MapEncoding.NotDescribed, + layout.MapEncoding (ValueNone, typeof), + "A list is no map." + ) + + [] + member _.``The extension data must not be described as a map`` () = + Assert.AreEqual( + MapEncoding.NotDescribed, + (layoutWith ignore).MapEncoding(memberOf typeof "Extra", typeof>), + "Its entries are written as properties of the document itself, so no property of the document holds the dictionary." + ) + + [] + member _.``A layout must ask the serializer about a value once`` () = + let layout = layoutWith (fun options -> options.Converters.Insert (0, StoredCountingColourConverter ())) + + let first = layout.EnumEncoding (ValueNone, typeof) + let writtenForFirst = StoredCountingColourConverter.Written + let second = layout.EnumEncoding (ValueNone, typeof) + + Assert.AreEqual(EnumEncoding.Number, first, "The converter writes numbers.") + + Assert.AreEqual(first, second, "The answer is the same every time.") + + Assert.IsGreaterThan (0, writtenForFirst, "The layout has the converter write the values to find the answer.") + + Assert.AreEqual( + writtenForFirst, + StoredCountingColourConverter.Written, + "The layout remembers the answer: the converter wrote nothing when the question was asked again." + ) + + [] + member _.``An enumeration without a value that has a name must be a number`` () = + let layout = layoutWith (fun options -> options.Converters.Add (JsonStringEnumConverter ())) + + Assert.AreEqual( + EnumEncoding.Number, + layout.EnumEncoding (ValueNone, namelessEnumeration "JsonLayoutValueTests.Nameless"), + "A converter of names writes a value without a name as its number, and this enumeration has no other value." + ) + + [] + member _.``An enumeration must not be described when its converter refuses the value that is asked`` () = + // The converter of names can be made to refuse a value without a name, and this enumeration has no other one. + let layout = layoutWith (fun options -> options.Converters.Add (JsonStringEnumConverter (null, false))) + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (ValueNone, namelessEnumeration "JsonLayoutValueTests.Refused"), + "The serializer writes no value of the enumeration, so there is nothing to describe." + ) + + // A converter of an application can refuse a value with the other exception that the serializer has for it. + let unsupporting = SerializerProfiles.fsharpDefault.Create () + unsupporting.Converters.Insert (0, StoredFirstColourConverter ()) + + Assert.Throws( + Action (fun () -> + JsonSerializer.Serialize (StoredColour.DarkBlue, unsupporting) + |> ignore + ), + "The converter should refuse the second value as not supported, or the test checks nothing." + ) + |> ignore + + Assert.AreEqual( + EnumEncoding.NotDescribed, + (LayoutAssert.WantLayout unsupporting).EnumEncoding(ValueNone, typeof), + "The serializer does not write every value of the enumeration, so the layout cannot say how they are written." + ) + + [] + member _.``An enumeration must not be described when its converter writes its values in more than one way`` () = + let layout = + layoutWith (fun options -> options.Converters.Insert (0, StoredHalfNamedColourConverter ())) + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (ValueNone, typeof), + "The converter writes the first value as its name and the other as its number, so a query can compare the values neither as numbers nor as texts." + ) + + [] + member _.``An enumeration must be described by what its converter writes for a value that has no name`` + (case : StoredEnumerationCase) + = + let layout = layoutWith (fun options -> options.Converters.Insert (0, case.Converter)) + + Assert.AreEqual( + case.Expected, + layout.EnumEncoding (ValueNone, case.EnumType), + $"The converter writes %s{case.Name}, so the layout should say %s{string case.Expected}." + ) + + [] + member _.``A value of a member with a converter of its own must not be described`` () = + let options = SerializerProfiles.fsharpDefault.Create () + let layout = LayoutAssert.WantLayout options + let sample = StoredValueSamples.ownConverterCatalog + let holderType = sample.Value.GetType () + let document = JsonSerializer.SerializeToElement (sample.Value, holderType, options) + + Assert.AreEqual( + JsonValueKind.String, + document.GetProperty("NamedColour").ValueKind, + "The converter of the member should write the name of the value, or the test checks nothing." + ) + + Assert.AreEqual( + JsonValueKind.Number, + document.GetProperty("NumberedColour").ValueKind, + "The converter of the member should write the number, or the test checks nothing." + ) + + let of' = memberOf holderType + + for name in + seq { + "NamedColour" + "NumberedColour" + "TextColour" + } do + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (of' name, typeof), + $"The converter of %s{name} writes the value, and nothing shows how." + ) + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (of' "MaybeNamedColour", typeof>), + "The same holds for a nullable, and for the value under it." + ) + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (of' "MaybeNamedColour", typeof), + "The converter of the member writes the value under the nullable." + ) + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (of' "Chosen", typeof), + "The converter of the member writes the option, and nothing shows what it writes for the enumeration under it." + ) + + Assert.AreEqual( + TupleEncoding.NotDescribed, + layout.TupleEncoding (of' "Pair", typeof), + "A tuple that the converter of the member writes is not described." + ) + + Assert.AreEqual( + CollectionEncoding.NotDescribed, + layout.CollectionEncoding (of' "Names", typeof), + "A list that the converter of the member writes is not described." + ) + + Assert.AreEqual( + MapEncoding.NotDescribed, + layout.MapEncoding (of' "Scores", typeof>), + "A map that the converter of the member writes is not described." + ) + + [] + member _.``A value that a converter of the options writes must not be described as what its type is`` () = + let layout = + layoutWith (fun options -> + options.Converters.Insert (0, StoredAsTextConverter()) + options.Converters.Insert (0, StoredAsTextConverter()) + options.Converters.Insert (0, StoredAsTextConverter>()) + ) + + Assert.AreEqual( + TupleEncoding.NotDescribed, + layout.TupleEncoding (ValueNone, typeof), + "The converter writes the tuple, in a way that the layout does not know." + ) + + Assert.AreEqual( + CollectionEncoding.NotDescribed, + layout.CollectionEncoding (ValueNone, typeof), + "The converter writes the list." + ) + + Assert.AreEqual( + MapEncoding.NotDescribed, + layout.MapEncoding (ValueNone, typeof>), + "The converter writes the map." + ) + + Assert.AreEqual( + TupleEncoding.Array, + layout.TupleEncoding (ValueNone, typeof), + "A tuple of another type is still written by FSharp.SystemTextJson." + ) + + [] + member _.``A tuple that a converter derived from the one of FSharp.SystemTextJson writes must not be described`` () = + let options = SerializerProfiles.fsharpDefault.Create () + options.Converters.Insert (0, StoredPairAsTextConverter ()) + let layout = LayoutAssert.WantLayout options + + Assert.AreEqual( + "\"(1, a)\"", + JsonSerializer.Serialize ((1, "a"), options), + "The converter of the application should write the pair, and as text." + ) + + Assert.AreEqual( + TupleEncoding.NotDescribed, + layout.TupleEncoding (ValueNone, typeof), + "The class of the converter is the application's, whatever it is derived from, so nothing shows what it writes." + ) + + [] + member _.``A member of a type that another converter writes must not be described`` () = + let options = SerializerProfiles.fsharpDefault.Create () + options.Converters.Insert (0, StoredAsTextConverter()) + let layout = LayoutAssert.WantLayout options + let field = memberOf typeof + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (field "Cover", typeof), + "The converter writes the album as a text, which has no members." + ) + + Assert.AreEqual( + TupleEncoding.NotDescribed, + layout.TupleEncoding (field "Size", typeof), + "So nothing is known about a tuple in it." + ) + + Assert.AreEqual( + CollectionEncoding.NotDescribed, + layout.CollectionEncoding (field "Tracks", typeof), + "Nor about a list in it." + ) + + Assert.AreEqual( + MapEncoding.NotDescribed, + layout.MapEncoding (field "Plays", typeof>), + "Nor about a map in it." + ) + + [] + member _.``A value must be described by the contract that a resolver of the caller makes for its type`` () = + // The resolver makes the contract of the enumeration itself, from a converter that writes text. + let options = SerializerProfiles.fsharpDefault.Create () + + options.TypeInfoResolver <- + StoredContractResolver(fun options -> + JsonMetadataServices.CreateValueInfo(options, StoredAsTextConverter()) + ) + + let layout = LayoutAssert.WantLayout options + let written = JsonSerializer.SerializeToElement (StoredCatalog "catalog-1", options) + + Assert.AreEqual( + JsonValueKind.String, + written.GetProperty("Colour").ValueKind, + "The serializer should write a member without a converter of its own by the contract of the resolver, or the test checks nothing." + ) + + Assert.AreEqual( + EnumEncoding.String, + layout.EnumEncoding (memberOf typeof "Colour", typeof), + "A member without a converter of its own is described by the contract of the resolver." + ) + + [] + member _.``A value must be described as the type that its member is read from is written`` () = + let options = SerializerProfiles.fsharpDefault.Create () + options.Converters.Add (StoredTalkAsTextConverter ()) + let layout = LayoutAssert.WantLayout options + + // The property as a quotation names it, also when it is read from the derived class. + let colour = nonNull (typeof.GetProperty "Colour") + + Assert.AreEqual( + EnumEncoding.Number, + layout.EnumEncoding (ValueSome { Holder = typeof; Member = colour }, typeof), + "The serializer writes the class that declares the member as an object." + ) + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (ValueSome { Holder = typeof; Member = colour }, typeof), + "A converter writes the class that inherits the member as a text, so no document of that class holds the value." + ) diff --git a/tests/Cosmos.Quotations.Tests/ModelMembers.fs b/tests/Cosmos.Quotations.Tests/ModelMembers.fs new file mode 100644 index 00000000..fca839f6 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/ModelMembers.fs @@ -0,0 +1,47 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Reflection + +/// +/// The members of a type of a test model that hold data, for the tests that compare what a layout says of every member +/// with a document that the serializer wrote. +/// +[] +module ModelMembers = + + /// The members of a type that hold data: its properties and fields, also the ones that are not public, without + /// what the compiler adds. + let ofType (holderType : Type) : MemberInfo seq = seq { + for found in + holderType.GetMembers ( + BindingFlags.Instance + ||| BindingFlags.Public + ||| BindingFlags.NonPublic + ) do + match found with + | :? PropertyInfo as property when property.GetIndexParameters().Length = 0 && property.CanRead -> found + // The field that the compiler makes for a property has a name that no source can write. + | :? FieldInfo as field when + not ( + field.Name.Contains ('@', StringComparison.Ordinal) + || field.Name.Contains ('<', StringComparison.Ordinal) + ) + -> + found + | _ -> () + } + + /// The value that a member holds in a value of the model. + let valueOf (holder : obj) (dataMember : MemberInfo) : objnull = + match dataMember with + | :? PropertyInfo as property -> property.GetValue holder + | :? FieldInfo as field -> field.GetValue holder + | other -> invalidOp $"The member is neither a property nor a field: %s{other.Name}" + + /// The type of the value of a member. + let typeOf (dataMember : MemberInfo) : Type = + match dataMember with + | :? PropertyInfo as property -> property.PropertyType + | :? FieldInfo as field -> field.FieldType + | other -> invalidOp $"The member is neither a property nor a field: %s{other.Name}" diff --git a/tests/Cosmos.Quotations.Tests/StoredModel.fs b/tests/Cosmos.Quotations.Tests/StoredModel.fs new file mode 100644 index 00000000..ea59a890 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/StoredModel.fs @@ -0,0 +1,529 @@ +// The types that the tests of the JSON layout serialize to see how the members of a document are named. They are made +// for the layout: every way to name a member is here once. A test writes a value of each type with the real serializer +// and compares what the layout says with what was written. +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Text.Json +open System.Text.Json.Serialization +open System.Text.Json.Serialization.Metadata +open System.Threading + +/// An enumeration, which is written as a number or by the name of the value. +type StoredColour = + | Red = 1 + | DarkBlue = 2 + +/// An enumeration of flags: a value can be several of them at once. +[] +type StoredAccess = + | None = 0 + | Read = 1 + | Write = 2 + +/// An enumeration whose values leave no gap from zero up to the last, so that the number after it is the smallest one +/// that no constant has and no combination of two constants is. +type StoredDense = + | Zero = 0 + | One = 1 + | Two = 2 + | Three = 3 + +/// An enumeration of the numbers from one to eight: every combination of two of the first seven is a constant itself, +/// so the first combination that is no constant needs the eighth. +type StoredWide = + | One = 1 + | Two = 2 + | Three = 3 + | Four = 4 + | Five = 5 + | Six = 6 + | Seven = 7 + | Eight = 8 + +/// A converter of texts that writes a text as it is, which is a converter that a member can name. +type StoredTextConverter () = + inherit JsonConverter () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : string | null = reader.GetString () + + /// + override _.Write (writer : Utf8JsonWriter, value : string | null, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue value + +/// The base of a class hierarchy, which System.Text.Json writes as objects whatever converters there are. +[] +type StoredDocument (id : string) = + + /// A property that is only read. + member _.Id = id + + /// A property that a derived class overrides. The name declared here belongs to this declaration only. + [] + abstract Tenant : string + + /// A property of the base class that can be set. + member val Note : string | null = null with get, set + + /// A property that a derived class overrides. + abstract Remark : string | null with get, set + +/// A derived class with a member for every rule that System.Text.Json has for the name of a property of an object. +type StoredPerson (id : string, name : string) = + inherit StoredDocument (id) + + /// A property named by the naming policy. + member _.Name = name + + /// The override: it declares no name of its own, so the serializer writes it under the name of the policy, + /// next to the property of the base class. + override _.Tenant = "tenant of " + id + + /// The override of a property that can be set. + override val Remark : string | null = null with get, set + + /// A property with a declared name. + [] + member val Nick : string | null = null with get, set + + /// A property that is never written. + [] + member val Secret : string | null = null with get, set + + /// A property that is never written and declares a name: it stands for a property that something else writes. + [] + member val Discriminator : string | null = null with get, set + + /// A nullable. + member val Age = Nullable() with get, set + + /// An option. + member val Choice : int option = None with get, set + + /// A value option. + member val ValueChoice : int voption = ValueNone with get, set + + /// A property that is not public and is written because it says so. + [] + member val internal Hidden : string | null = null with get, set + + /// A field that is written because it says so. + [] + val mutable subject : string | null + + /// A field that is written only when the options include fields. + [] + val mutable plainField : string | null + + /// The properties of the document that no member stands for. + [] + member val Extra = Dictionary(StringComparer.Ordinal) with get, set + +/// A class that System.Text.Json refuses to write: a struct is never null, so it cannot be ignored when it is. +type StoredRefused (id : string) = + + /// A property that is only read. + member _.Id = id + + /// The member that the serializer refuses. + [] + member val Choice : int voption = ValueNone with get, set + +/// A record that is the value of a field of another record. +type StoredAuthor = { + /// The name of the author. + Name : string +} + +/// A record whose fields only its own file can reach. FSharp.SystemTextJson writes them all the same. +type StoredKey = private { + /// A field that always has a value. + Code : string +} with + + /// A key with the code. + static member Of (code : string) : StoredKey = { Code = code } + +/// A base class with a member that is never written and declares a name: it stands for a property that something else +/// writes. +[] +type StoredTagged () = + + /// The member. + [] + abstract Tag : string + +/// A class that overrides the member, which it does not write either, and declares no name for it. +type StoredTaggedAgain () = + inherit StoredTagged () + + /// + [] + override _.Tag = "again" + +/// A record with a field for every rule that FSharp.SystemTextJson has for a field of a record. +type StoredEntry = { + /// A field named by the naming policy. + Title : string + /// A field with a name declared the way System.Text.Json declares one. + [] + Body : string + /// A field with a name declared the way FSharp.SystemTextJson declares one, which System.Text.Json does not read. + [] + Tag : string + /// A field with a name that is given for a field of a union case. It is not the name of this field, which is + /// named by the naming policy. + [] + Subtitle : string + /// A field that is never written. + [] + Draft : string + /// A field that is never written and declares a name: it stands for a property that something else writes. + [] + Discriminator : string + /// A field that System.Text.Json leaves out when it is null and that FSharp.SystemTextJson never writes: it does + /// not read the condition. + [] + Dropped : string | null + /// A reference that can be null. + Comment : string | null + /// A nullable. + Count : Nullable + /// An option. + Choice : int option + /// A value option. + ValueChoice : int voption + /// An option of an option. + Nested : string option option + /// A record. + Author : StoredAuthor +} with + + /// A property that is not a field. FSharp.SystemTextJson writes it only when its options include properties. + member this.Summary = this.Title + "!" + + /// A property that is not a field and asks to be written. + [] + member this.Shout = this.Title.ToUpperInvariant () + + /// A property that is not a field and declares a name. Where FSharp.SystemTextJson does not write it, it stands + /// for a property that something else writes. + [] + member this.Initial = this.Title.Substring (0, 1) + + /// A property that is not public. FSharp.SystemTextJson looks at the public properties of a record only, so it + /// does not write this one, whatever its options say. + member internal this.Aside = "aside of " + this.Title + + /// A property that is not public and asks to be written. System.Text.Json writes it for an object, and + /// FSharp.SystemTextJson does not for a record. + [] + member internal this.Whisper = "whisper of " + this.Title + +/// A record with two fields whose names a naming policy makes one: camel case spells both as "title". +type StoredTwin = { + /// A field. + Title : string + /// Another one, whose name differs from the first one by the case of a letter. + title : string +} + +/// A record with two fields that declare one name, each the way of one of the libraries. +type StoredNamedTwice = { + /// A field with a name declared the way FSharp.SystemTextJson declares one. + [] + First : int + /// A field with the same name, declared the way System.Text.Json declares one. + [] + Second : int +} + +/// A record with a property that asks to be written under the name of a field. +type StoredClash = { + /// A field. + Total : int +} with + + /// A property that is written, and has the name of the field. + [] + member this.Sum = this.Total + 1 + +/// A record with a field that is never written and declares the name of one that is. +type StoredHidden = { + /// A field. + Visible : int + /// A field that is never written, and stands for a property of the name of the other one. + [] + Hidden : int +} + +/// A generic record, which can be given options for all the types that are made of it. +type StoredBox<'Item> = { + /// What the box holds. + Item : 'Item + /// An option in a generic record. + Label : string option +} + +/// A struct record. +[] +type StoredPoint = { + /// A field that always has a value, and declares a name. + [] + X : int + /// An option in a struct record. + Label : string option +} + +/// A converter that writes a point as text, which a layout cannot look into. +type StoredPointAsTextConverter () = + inherit JsonConverter () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : StoredPoint = + reader.Skip () + { X = 0; Label = None } + + /// + override _.Write (writer : Utf8JsonWriter, value : StoredPoint, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue $"%d{value.X}" + +/// A converter that writes a span as text. +type StoredSpanAsTextConverter () = + inherit JsonConverter () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : StoredSpan = + reader.Skip () + { From = 0; To = 0; Note = None } + + /// + override _.Write (writer : Utf8JsonWriter, value : StoredSpan, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue $"%d{value.From}-%d{value.To}" + +/// A record that names its converter in an attribute of the type. The serializer asks the converters of the options +/// first, so the named converter writes the record only when none of them takes it. +and [)>] StoredSpan = { + /// A field that always has a value. + From : int + /// Another one. + To : int + /// An option. + Note : string option +} + +/// A class with a member that names a converter of its own. +type StoredMeeting () = + + /// A reference whose converter writes a text as it is. + [)>] + member val Topic : string | null = null with get, set + + /// A reference that follows the options. + member val Room : string | null = null with get, set + + /// An enumeration that follows the options. + member val Colour = StoredColour.Red with get, set + +/// A class that inherits its members from one that System.Text.Json writes as an object. A test has a converter of +/// the options write it as text. +type StoredTalk () = + inherit StoredMeeting () + +/// A converter that writes a talk as text, which a layout cannot look into. +type StoredTalkAsTextConverter () = + inherit JsonConverter () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : StoredTalk = + reader.Skip () + StoredTalk () + + /// + override _.Write (writer : Utf8JsonWriter, _ : StoredTalk, _ : JsonSerializerOptions) : unit = writer.WriteStringValue "talk" + +/// +/// A resolver of contracts of an application that makes the contract of one type itself, without looking at the +/// converters of the options it is asked with. Every other contract is the work of the serializer. +/// +/// Makes the contract of the type for the options that ask. +type StoredContractResolver<'Value> (make : JsonSerializerOptions -> JsonTypeInfo) = + inherit DefaultJsonTypeInfoResolver () + + /// + override _.GetTypeInfo (valueType : Type, options : JsonSerializerOptions) : JsonTypeInfo = + if Type.(=) (valueType, typeof<'Value>) then + make options + else + base.GetTypeInfo (valueType, options) + +/// A converter factory of an application that is derived from the one of FSharp.SystemTextJson. It makes the +/// converters that the library makes, and a class derived from the library can make them with other options than the +/// ones that it shows. +type StoredDerivedFactory () = + inherit JsonFSharpConverter (JsonFSharpOptions.Default ()) + +/// A resolver of contracts of an application that has a contract for no type: the serializer refuses every type. +type StoredBareResolver () = + + interface IJsonTypeInfoResolver with + + /// + member _.GetTypeInfo (_ : Type, _ : JsonSerializerOptions) : JsonTypeInfo | null = null + +/// A record that asks for options of its own in an attribute. +[] +type StoredMarked = { + /// A field that always has a value. + Text : string + /// An option that the options of the attribute leave out without a value. + Note : string option +} + +/// +/// A naming policy that counts how often it spells a name. A test sees by the count whether the layout worked an +/// answer out again. Every type argument has a count of its own: tests run at a time, and each test that counts names +/// a type that no other test names. +/// +type StoredCountingNamingPolicy<'Counted> () = + inherit JsonNamingPolicy () + + static let mutable spelled = 0 + + /// How often the policies of this type have spelled a name. + static member Spelled : int = Volatile.Read &spelled + + /// + override _.ConvertName (name : string) : string = + Interlocked.Increment &spelled |> ignore + name + +/// +/// A naming policy that counts how often it spells a name, like the one above, and holds every call at a gate until a +/// test opens it, so that the calls of several threads meet inside it. Only one test may use it. +/// +type StoredGatedNamingPolicy () = + inherit JsonNamingPolicy () + + static let mutable spelled = 0 + static let gate = new ManualResetEventSlim (true) + + /// How often the policies of this type have spelled a name. + static member Spelled : int = Volatile.Read &spelled + + /// The gate that every call waits at; open until a test closes it. + static member Gate : ManualResetEventSlim = gate + + /// + override _.ConvertName (name : string) : string = + Interlocked.Increment &spelled |> ignore + gate.Wait () + name + +/// A record whose field names are spelled by a policy that counts. Only one test may ask about it. +type StoredCounted = { + /// A field. + Title : string +} + +/// A record whose field names are spelled by a policy that waits at a gate. Only one test may ask about it. +type StoredGated = { + /// A field. + Title : string +} + +/// +/// A type of the model as the tests write it: with every member holding a value that no other member holds, so that +/// the member can be found in the document by its value. +/// +[] +type StoredSample = { + /// What the type is; the name of a test result holds it. + Name : string + /// The value. + Value : obj +} + +/// The values of the model. +module StoredSamples = + + /// The person with every member set. + let person = + let person = + StoredPerson ( + "id-1", + "name-1", + Note = "note-1", + Remark = "remark-1", + Nick = "nick-1", + Secret = "secret-1", + Discriminator = "person+v1", + Age = Nullable 12, + Choice = Some 13, + ValueChoice = ValueSome 14, + Hidden = "hidden-1" + ) + + person.subject <- "subject-1" + person.plainField <- "plain-1" + { Name = "a class"; Value = person } + + /// The record. + let entry = { + Name = "a record" + Value = + ({ + Title = "title-1" + Body = "body-1" + Tag = "tag-1" + Subtitle = "subtitle-1" + Draft = "draft-1" + Discriminator = "entry+v1" + Dropped = "dropped-1" + Comment = "comment-1" + Count = Nullable 31 + Choice = Some 32 + ValueChoice = ValueSome 33 + Nested = Some (Some "nested-1") + Author = { Name = "author-1" } + } + : StoredEntry) + } + + /// The struct record. + let point = { + Name = "a struct record" + Value = ({ X = 51; Label = Some "label-1" } : StoredPoint) + } + + /// A generic record. + let box = { + Name = "a generic record" + Value = ({ Item = 71; Label = Some "label-1" } : StoredBox) + } + + /// An anonymous record. + let anonymous = { + Name = "an anonymous record" + Value = {| Title = "title-1"; Choice = Some 61; ValueChoice = ValueSome 62 |} + } + + /// The record that asks for options of its own. + let marked = { + Name = "a record with options in an attribute" + Value = ({ Text = "text-1"; Note = Some "note-1" } : StoredMarked) + } + + /// Every sample. + let all = + seq { + person + entry + point + box + anonymous + marked + } + |> Collections.Immutable.ImmutableArray.CreateRange diff --git a/tests/Cosmos.Quotations.Tests/StoredUnions.fs b/tests/Cosmos.Quotations.Tests/StoredUnions.fs new file mode 100644 index 00000000..bb2089d5 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/StoredUnions.fs @@ -0,0 +1,386 @@ +// The unions that the tests of the JSON layout serialize to see how a union is written. A test writes a value of +// every case with the real serializer and looks in the document for what the layout says: the mark of the case, which +// no value of another case may have, and the values of the fields at the places that the layout gives. +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Immutable +open System.Text.Json +open System.Text.Json.Serialization +open FSharp.Reflection + +/// A union with a case for every way to declare a case and its fields that the layout describes. +type StoredShape = + /// A case without fields. + | Blank + /// A case with one field that the source names. + | Circle of radius : int + /// A case with two fields that the source does not name. + | Rect of int * string + /// A case whose one field is a record. + | Signed of StoredAuthor + /// A case with a name declared the way FSharp.SystemTextJson declares one, and a field that is an option. + | [] Polygon of sides : int * label : string option + /// A case with a name declared the way System.Text.Json declares one. + | [] Point + +/// A union without any field. +type StoredSide = + /// A case that is written by its name. + | Front + /// A case with a name that it declares. + | [] Back + +/// A union with a case that declares the name of a field, which the layout does not describe. +type StoredPairing = + /// A case that declares the name of a field, and whose fields are of one type. + | [] Pair of int * int + /// A case as any other. + | Single of int + +/// A union without any field, with cases that declare a number and a boolean in place of a name. +type StoredLevel = + /// A case that is written by its name. + | Low + /// A case that is written as a number. + | [] High + /// A case that is written as a boolean. + | [] Sure + +/// A union with one case that declares a number in place of its name, next to a case that is written by its name. +type StoredNumbered = + /// A case that is written as a number. + | [] Seven + /// A case that is written by its name. + | Eight + +/// A union with one case that declares a boolean in place of its name, next to a case that is written by its name. +type StoredBoolean = + /// A case that is written as a boolean. + | [] Affirmed + /// A case that is written by its name. + | Denied + +/// A union with a case that is represented by null. +[] +type StoredGrade = + /// The case that is null. + | Ungraded + /// A case with a value. + | Graded of points : int + +/// A union with one case that has one field, which is how an application wraps a value. +type StoredTicket = StoredTicket of Guid + +/// A union with one case that has several fields. +type StoredRange = StoredRange of first : int * last : int + +/// A union with one case that has no field. +type StoredToken = | StoredToken + +/// A union with a case whose one field is a record that has a private representation. +type StoredVault = + /// The case with the record. + | Held of StoredKey + /// A case without fields. + | Vacant + +/// A struct union. +[] +type StoredSwitch = + /// A case without fields. + | On + /// A case with a field. + | Off of reason : string + +/// A union whose cases only its own module can use. +type StoredSecret = + private + | Code of code : int + | Unlocked + + /// A value of the case with a field. + static member OfCode (code : int) : StoredSecret = Code code + + /// The value of the case without a field. + static member Open : StoredSecret = Unlocked + +/// A generic union. +type StoredOutcome<'Value> = + /// A case with a field of the type argument. + | Fine of 'Value + /// A case with a field of a fixed type. + | Failed of reason : string + +/// A union with options of its own in an attribute that sets the whole encoding. +[] +type StoredStamp = + /// A case without fields. + | Unstamped + /// A case with fields. + | Stamped of text : string * size : int + +/// +/// A union with options of its own in an attribute that sets a part of the encoding. FSharp.SystemTextJson replaces +/// the whole encoding of such options by the common one, so the part is lost, and the names stay. +/// +[] +type StoredLabel = + /// A case without fields. + | Unlabelled + /// A case with fields. + | Labelled of text : string * size : int + +/// +/// A record that names the converter of FSharp.SystemTextJson in an attribute. The options that the attribute makes are +/// the record's own when the common options let an attribute give them. +/// +[] +type StoredSigner = { + /// A field that always has a value. + SignedAs : string + /// An option. + Alias : string option +} + +/// A union with a case whose one field is that record. +type StoredDeal = + /// The case with the record. + | Dealt of StoredSigner + /// A case without fields. + | Undealt + +/// A union that FSharp.SystemTextJson refuses: a case may have one attribute with its names, and this one has two. +type StoredTwice = + /// The case with two attributes. + | [] Named + /// A case as any other. + | Plain + +/// A union whose cases declare one tag. +type StoredSameTag = + /// A case with a tag. + | [] Alpha + /// A case with the same tag. + | [] Beta of int + +/// A union whose cases a naming policy writes with one tag: snake case spells both of them as "foo_bar". +type StoredFoldedTag = + /// A case. + | FooBar + /// A case whose name differs from the first one by an underscore. + | Foo_Bar of int + +/// A union whose cases declare tags that differ by the case of the letters only. +type StoredCasedTag = + /// A case with a tag in small letters. + | [] Lower + /// A case with a tag in capital letters. + | [] Upper of int + +/// +/// A converter factory of an application that makes the converter of FSharp.SystemTextJson for a union itself, with a +/// naming policy for the tags that no options show: the tags are in capital letters. +/// +type StoredLoudUnionConverterFactory () = + inherit JsonConverterFactory () + + /// + override _.CanConvert (typeToConvert : Type) : bool = FSharpType.IsUnion (typeToConvert, true) + + /// + override _.CreateConverter (typeToConvert : Type, _ : JsonSerializerOptions) : JsonConverter | null = + JsonUnionConverter(JsonFSharpOptions.Default().WithUnionTagNamingPolicy JsonNamingPolicy.SnakeCaseUpper) + .CreateConverter(typeToConvert, JsonSerializerOptions ()) + +/// A record with a member of a union type, for every union: a test asks about the union as the value of the member. +type StoredHolder<'Union> = { + /// The union. + Held : 'Union +} + +/// A class with members of a union type. +type StoredDrawing () = + + /// A union that is written as the options say. + member val Shape = Blank with get, set + + /// A union with a converter of its own, which is the one of FSharp.SystemTextJson with options of its own. + [)>] + member val Loud = Blank with get, set + + /// A union that the serializer never writes. + [] + member val Hidden = Blank with get, set + +/// A way to have FSharp.SystemTextJson write the name of the tag of a union twice in one object. +type StoredTagTwice = { + /// What gives a case a second property of the name of the tag; the name of a test result holds it. + Reason : string + /// The name of the tag. + TagName : string + /// The naming policy of the serializer; none when the names are written as they are. + PropertyNaming : JsonNamingPolicy | null + /// The options of FSharp.SystemTextJson that the union is written with. + Settings : JsonFSharpOptions + /// A value of a case that is written with the name twice. + Value : StoredShape +} + +/// The values of a union type that the tests write: one of every case at least. +[] +type StoredUnionSample = { + /// What the union is; the name of a test result holds it. + Name : string + /// The union type. + UnionType : Type + /// The values. + Values : ImmutableArray +} + +/// The values of the unions. +module StoredUnionSamples = + + /// A sample of a union type. + let private sample (name : string) (values : 'Union seq) : StoredUnionSample = { + Name = name + UnionType = typeof<'Union> + Values = values |> Seq.map box |> ImmutableArray.CreateRange + } + + /// Every union that is described whenever the serializer writes it, with a value of every case. + let all = + seq { + sample + "a union with every kind of case" + (seq { + Blank + Circle 3 + Rect (4, "rect") + Signed { Name = "signer" } + Polygon (5, Some "label") + Polygon (6, None) + Point + }) + sample + "a union without fields" + (seq { + Front + Back + }) + sample "a union that wraps a value" (Seq.singleton (StoredTicket (Guid "0f8fad5b-d9cb-469f-a165-70867728950e"))) + sample "a union with one case of several fields" (Seq.singleton (StoredRange (1, 9))) + sample "a union with one case without a field" (Seq.singleton StoredToken) + sample + "a union with tags that differ by the case of the letters" + (seq { + Lower + Upper 4 + }) + sample + "a union with a record that has a private representation" + (seq { + Held (StoredKey.Of "key-1") + Vacant + }) + sample + "a struct union" + (seq { + On + Off "reason" + }) + sample + "a union with private cases" + (seq { + StoredSecret.OfCode 11 + StoredSecret.Open + }) + sample + "a generic union of a number" + (seq { + Fine 12 + Failed "failure" + }) + sample + "a generic union of a text" + (seq { + Fine "fine" + Failed "failure" + }) + // The attributes ask for options of their own, which the common options do not allow: they are ignored. + sample + "a union with the whole encoding in an attribute" + (seq { + Unstamped + Stamped ("stamp", 13) + }) + sample + "a union with a part of the encoding in an attribute" + (seq { + Unlabelled + Labelled ("label", 14) + }) + sample + "a union with a record that has options in an attribute" + (seq { + Dealt { SignedAs = "signer"; Alias = Some "alias" } + Undealt + }) + } + |> ImmutableArray.CreateRange + + /// The unions that the layout does not describe whatever the options are, with the reason. + let notDescribed : ImmutableArray = + seq { + struct ("its tags are a number and a boolean", typeof) + struct ("one of its tags is a number", typeof) + struct ("one of its tags is a boolean", typeof) + struct ("a case of it is represented by null", typeof) + struct ("a case of it declares the name of a field", typeof) + struct ("two of its cases declare one tag", typeof) + } + |> ImmutableArray.CreateRange + + /// Every way to have the name of the tag written twice. + let tagsTwice = + seq { + { + Reason = "a field has the name of the tag" + TagName = "radius" + PropertyNaming = null + Settings = JsonFSharpOptions.Default().WithUnionInternalTag().WithUnionNamedFields().WithUnionTagName "radius" + Value = Circle 3 + } + { + Reason = "a member of the record of a case has the name of the tag" + TagName = "Name" + PropertyNaming = null + Settings = + JsonFSharpOptions + .Default() + .WithUnionInternalTag() + .WithUnionNamedFields() + .WithUnionUnwrapRecordCases() + .WithUnionTagName + "Name" + Value = Signed { Name = "signer" } + } + { + Reason = "a member of the record of a case has the name of the tag after the naming policy has spelled it" + TagName = "name" + PropertyNaming = JsonNamingPolicy.CamelCase + Settings = + JsonFSharpOptions + .Default() + .WithUnionInternalTag() + .WithUnionNamedFields() + .WithUnionUnwrapRecordCases() + .WithUnionTagName + "name" + Value = Signed { Name = "signer" } + } + } + |> ImmutableArray.CreateRange diff --git a/tests/Cosmos.Quotations.Tests/StoredValues.fs b/tests/Cosmos.Quotations.Tests/StoredValues.fs new file mode 100644 index 00000000..b1a627d1 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/StoredValues.fs @@ -0,0 +1,423 @@ +// The types that the tests of the JSON layout serialize to see how values that are no objects are written: +// enumerations, tuples, collections and maps. A test writes a value of each type with the real serializer and +// compares what the layout says about every member with what was written. +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open System.Text.Json +open System.Text.Json.Serialization +open System.Threading + +open FSharp.Azure.Cosmos.Quotations + +/// A converter that writes any value as the text that the value gives of itself, which a layout cannot look into. +type StoredAsTextConverter<'Value> () = + inherit JsonConverter<'Value> () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : 'Value = + reader.Skip () + Unchecked.defaultof<'Value> + + /// + override _.Write (writer : Utf8JsonWriter, value : 'Value, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue (string (box value)) + +/// +/// A converter of a pair that is derived from the base class of the tuple converters of FSharp.SystemTextJson and +/// writes the pair as text all the same. The base class is public, so an application can have such a converter. +/// +type StoredPairAsTextConverter () = + inherit BaseJsonTupleConverter () + + /// + override _.ReadCore (reader : byref, _ : JsonSerializerOptions) : int * string = + reader.Skip () + (0, "") + + /// + override _.WriteCore (writer : Utf8JsonWriter, value : int * string, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue (string (box value)) + + /// + override _.Write (writer : Utf8JsonWriter, value : int * string, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue (string (box value)) + +/// A converter factory that writes a value of any type as text; a member names it to be written that way. +type StoredAsTextConverterFactory () = + inherit JsonConverterFactory () + + /// + override _.CanConvert (_ : Type) : bool = true + + /// + override _.CreateConverter (typeToConvert : Type, _ : JsonSerializerOptions) : JsonConverter | null = + match Activator.CreateInstance (typedefof>.MakeGenericType typeToConvert) with + | :? JsonConverter as converter -> converter + | _ -> null + +/// +/// A converter of the enumeration of colours that writes the first value as its name and every other value as its +/// number, so that the enumeration is written in no one way. +/// +type StoredHalfNamedColourConverter () = + inherit JsonConverter () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : StoredColour = + match reader.TokenType with + | JsonTokenType.String -> StoredColour.Red + | _ -> enum(reader.GetInt32 ()) + + /// + override _.Write (writer : Utf8JsonWriter, value : StoredColour, _ : JsonSerializerOptions) : unit = + match value with + | StoredColour.Red -> writer.WriteStringValue (nameof StoredColour.Red) + | other -> writer.WriteNumberValue (int other) + +/// +/// A converter of the enumeration of colours that refuses every value but the first, as a converter does that was +/// written for the values of its day: with the exception that says that a value is not supported. +/// +type StoredFirstColourConverter () = + inherit JsonConverter () + + /// + override _.Read (_ : byref, _ : Type, _ : JsonSerializerOptions) : StoredColour = StoredColour.Red + + /// + override _.Write (writer : Utf8JsonWriter, value : StoredColour, _ : JsonSerializerOptions) : unit = + match value with + | StoredColour.Red -> writer.WriteStringValue (nameof StoredColour.Red) + | other -> raise (NotSupportedException $"The converter does not write the colour %d{int other}.") + +/// +/// A converter of the enumeration of colours that writes numbers and counts how often it writes. A test sees by the +/// count whether the layout asked the serializer again. Only one test may use it. +/// +type StoredCountingColourConverter () = + inherit JsonConverter () + + static let mutable written = 0 + + /// How often the converters of this type have written a value. + static member Written : int = Volatile.Read &written + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : StoredColour = + enum(reader.GetInt32 ()) + + /// + override _.Write (writer : Utf8JsonWriter, value : StoredColour, _ : JsonSerializerOptions) : unit = + Interlocked.Increment &written |> ignore + writer.WriteNumberValue (int value) + +/// +/// A converter of any type that writes each value as its rule says, for the test of a converter that writes some +/// values in a way of its own. It only writes: what a converter reads is no part of what a layout looks at. +/// +type StoredRuleConverter<'Value> (write : Utf8JsonWriter -> 'Value -> unit) = + inherit JsonConverter<'Value> () + + /// + override _.Read (_ : byref, _ : Type, _ : JsonSerializerOptions) : 'Value = + raise (NotSupportedException "The converter of the test only writes.") + + /// + override _.Write (writer : Utf8JsonWriter, value : 'Value, _ : JsonSerializerOptions) : unit = write writer value + +/// An enumeration, a converter that writes its values, and how the layout should describe the enumeration then. +[] +type StoredEnumerationCase = { + /// What the converter writes, in words. + Name : string + /// The enumeration that the converter writes. + EnumType : Type + /// The converter, which stands before every other in the options. + Converter : JsonConverter + /// What the layout should say. + Expected : EnumEncoding +} + +/// A class with a member for every kind of value that is no object. +type StoredCatalog (id : string) = + + /// A property that is only read. + member _.Id = id + + /// An enumeration that is written as the options say. + member val Colour = StoredColour.Red with get, set + + /// Flags. + member val Access = StoredAccess.None with get, set + + /// A nullable enumeration. + member val MaybeColour = Nullable() with get, set + + /// An option of an enumeration: the value under the option is written as any enumeration is. + member val Preferred : StoredColour option = None with get, set + + /// A reference tuple. + member val Pair : int * string = (0, "") with get, set + + /// A struct tuple. + member val StructPair : struct (int * string) = struct (0, "") with get, set + + /// A tuple of eight items, which holds the eighth in a tuple of its own. + member val Octet : int * int * int * int * int * int * int * int = (0, 0, 0, 0, 0, 0, 0, 0) with get, set + + /// A value option of a tuple: the value under it is written as any tuple is. + member val Spare : (int * string) voption = ValueNone with get, set + + /// An array. + member val Numbers : int array = [||] with get, set + + /// An F# list. + member val Names : string list = [] with get, set + + /// An F# set. + member val Marks : Set = Set.empty with get, set + + /// An immutable array. + member val Codes : ImmutableArray = ImmutableArray.Empty with get, set + + /// A list that can change. + member val Items : ResizeArray = ResizeArray() with get, set + + /// A set that can change. + member val Keys : HashSet = HashSet(StringComparer.Ordinal) with get, set + + /// A sequence. + member val Sequence : int seq = Seq.empty with get, set + + /// An array of bytes, which is written as one text and not as an array. + member val Bytes : byte array = [||] with get, set + + /// An F# map with texts as keys. + member val Scores : Map = Map.empty with get, set + + /// An F# map with numbers as keys. + member val ById : Map = Map.empty with get, set + + /// A dictionary. + member val Lookup : Dictionary = Dictionary(StringComparer.Ordinal) with get, set + + /// A dictionary that is only read. + member val Index : IReadOnlyDictionary = Dictionary(StringComparer.Ordinal) with get, set + +/// A record with a field for every kind of value that is no object. +type StoredCatalogEntry = { + /// An enumeration that is written as the options say. + Colour : StoredColour + /// An enumeration whose field names a converter. System.Text.Json follows it, and FSharp.SystemTextJson does not + /// read it. + [)>] + NamedColour : StoredColour + /// An enumeration that is never written. + [] + Draft : StoredColour + /// Flags. + Access : StoredAccess + /// A nullable enumeration. + MaybeColour : Nullable + /// An option of an enumeration. + Preferred : StoredColour option + /// A reference tuple. + Pair : int * string + /// A struct tuple. + StructPair : struct (int * string) + /// A tuple of eight items. + Octet : int * int * int * int * int * int * int * int + /// A value option of a tuple. + Spare : (int * string) voption + /// An array. + Numbers : int array + /// An F# list. + Names : string list + /// An F# set. + Marks : Set + /// An immutable array. + Codes : ImmutableArray + /// An array of bytes. + Bytes : byte array + /// An F# map with texts as keys. + Scores : Map + /// An F# map with numbers as keys. + ById : Map + /// A dictionary. + Lookup : Dictionary +} with + + /// A property that is no field and says that it is written, with a converter of its own. + [)>] + member this.IncludedColour = this.Colour + + /// A property that is no field: FSharp.SystemTextJson writes it only when its options include such properties. + member this.OtherColour = this.Colour + +/// A class whose members name a converter of their own, which the layout does not look into. +type StoredOwnConverterCatalog () = + + /// An enumeration with a converter of its own, which writes the name of the value. + [)>] + member val NamedColour = StoredColour.Red with get, set + + /// An enumeration with a converter of its own, which writes the number also when the options write names. + [>)>] + member val NumberedColour = StoredColour.Red with get, set + + /// A nullable enumeration with a converter of its own, which writes the value under the nullable. + [)>] + member val MaybeNamedColour = Nullable() with get, set + + /// An enumeration that a converter of the member writes as a text. + [)>] + member val TextColour = StoredColour.Red with get, set + + /// An option of an enumeration that the converter of the member writes: it writes the option, and nothing shows + /// what it writes for the enumeration under it. + [)>] + member val Chosen : StoredColour option = None with get, set + + /// A tuple that the converter of the member writes. + [)>] + member val Pair : int * string = (0, "") with get, set + + /// A list that the converter of the member writes. + [)>] + member val Names : string list = [] with get, set + + /// A map that the converter of the member writes. + [)>] + member val Scores : Map = Map.empty with get, set + +/// A record that a test has a converter of the options write as text, so that nothing is known about its fields. +type StoredAlbum = { + /// An enumeration. + Cover : StoredColour + /// A tuple. + Size : int * int + /// A list. + Tracks : string list + /// A map. + Plays : Map +} + +/// A value of the model of values, as the tests write it. +[] +type StoredValueSample = { + /// What the type is; the name of a test result holds it. + Name : string + /// The value, with something in every member. + Value : obj +} + +/// The values of the model of values. +module StoredValueSamples = + + /// A dictionary with one key, made anew for every member: a dictionary can change, so no two members share one. + let private lookup () : Dictionary = + Dictionary(Seq.singleton (KeyValuePair ("a", 1)), StringComparer.Ordinal) + + /// The class. + let catalog = { + Name = "a class with values that are no objects" + Value = + StoredCatalog ( + "id-1", + Colour = StoredColour.DarkBlue, + Access = (StoredAccess.Read ||| StoredAccess.Write), + MaybeColour = Nullable StoredColour.Red, + Preferred = Some StoredColour.DarkBlue, + Pair = (1, "one"), + StructPair = struct (2, "two"), + Octet = (1, 2, 3, 4, 5, 6, 7, 8), + Spare = ValueSome (3, "three"), + Numbers = [| 1; 2 |], + Names = [ "a"; "b" ], + Marks = Set.ofArray [| 1; 2 |], + Codes = ImmutableArray.Create (1, 2), + Items = ResizeArray [| 1; 2 |], + Keys = HashSet([| "k" |], StringComparer.Ordinal), + Sequence = [| 1; 2 |], + Bytes = [| 1uy; 2uy |], + Scores = Map.ofArray [| ("a", 1) |], + ById = Map.ofArray [| (1, "a") |], + Lookup = lookup (), + Index = lookup () + ) + } + + /// The record. + let entry = { + Name = "a record with values that are no objects" + Value = + ({ + Colour = StoredColour.DarkBlue + NamedColour = StoredColour.DarkBlue + Draft = StoredColour.DarkBlue + Access = StoredAccess.Read ||| StoredAccess.Write + MaybeColour = Nullable StoredColour.Red + Preferred = Some StoredColour.DarkBlue + Pair = (1, "one") + StructPair = struct (2, "two") + Octet = (1, 2, 3, 4, 5, 6, 7, 8) + Spare = ValueSome (3, "three") + Numbers = [| 1; 2 |] + Names = [ "a"; "b" ] + Marks = Set.ofArray [| 1; 2 |] + Codes = ImmutableArray.Create (1, 2) + Bytes = [| 1uy; 2uy |] + Scores = Map.ofArray [| ("a", 1) |] + ById = Map.ofArray [| (1, "a") |] + Lookup = lookup () + } + : StoredCatalogEntry) + } + + /// The class whose members name a converter of their own. + let ownConverterCatalog = { + Name = "a class whose members name a converter of their own" + Value = + StoredOwnConverterCatalog ( + NamedColour = StoredColour.DarkBlue, + NumberedColour = StoredColour.DarkBlue, + MaybeNamedColour = Nullable StoredColour.Red, + TextColour = StoredColour.DarkBlue, + Chosen = Some StoredColour.DarkBlue, + Pair = (1, "one"), + Names = [ "a"; "b" ], + Scores = Map.ofArray [| ("a", 1) |] + ) + } + + /// The samples that the layout describes member by member. + let all = + seq { + catalog + entry + } + |> ImmutableArray.CreateRange + + /// Values of every kind that are no members: what a collection or a tuple holds, with the type each is asked as. + let alone : ImmutableArray = + seq { + struct ("an enumeration", box StoredColour.DarkBlue, typeof) + struct ("flags", box (StoredAccess.Read ||| StoredAccess.Write), typeof) + struct ("a nullable enumeration", box StoredColour.Red, typeof>) + struct ("a pair", box (1, "one"), typeof) + struct ("a struct pair", box (struct (2, "two")), typeof) + struct ("a tuple of eight", box (1, 2, 3, 4, 5, 6, 7, 8), typeof) + struct ("an array", box [| 1; 2 |], typeof) + struct ("a list", box [ "a"; "b" ], typeof) + struct ("a set", box (Set.ofArray [| 1; 2 |]), typeof>) + struct ("an immutable array", box (ImmutableArray.Create (1, 2)), typeof>) + struct ("bytes", box [| 1uy; 2uy |], typeof) + struct ("a text", box "ab", typeof) + struct ("a map of texts", box (Map.ofArray [| ("a", 1) |]), typeof>) + struct ("a map of numbers", box (Map.ofArray [| (1, "a") |]), typeof>) + struct ("a dictionary", box (lookup ()), typeof>) + } + |> ImmutableArray.CreateRange diff --git a/tests/Cosmos.Quotations.Tests/TestCategories.fs b/tests/Cosmos.Quotations.Tests/TestCategories.fs index 1e8348c0..923300bd 100644 --- a/tests/Cosmos.Quotations.Tests/TestCategories.fs +++ b/tests/Cosmos.Quotations.Tests/TestCategories.fs @@ -16,8 +16,11 @@ type EvaluatorUnitTestCategoryAttribute () = override _.TestCategories = [| "Unit"; "Evaluator" |] :> IList /// -/// Categorizes a unit test of the layout that says how the serializer writes the members of a document: -/// . +/// Categorizes a unit test of the layout that says how the serializer writes a document: +/// , +/// , +/// and +/// . /// type JsonLayoutUnitTestCategoryAttribute () = inherit TestCategoryBaseAttribute () diff --git a/tests/Cosmos.Quotations.Tests/WrittenDocuments.fs b/tests/Cosmos.Quotations.Tests/WrittenDocuments.fs new file mode 100644 index 00000000..44ce9854 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/WrittenDocuments.fs @@ -0,0 +1,335 @@ +// What a layout says, compared with a document that the serializer wrote: the functions that the tests of the JSON +// layout share. The serializer is the oracle in all of them, so each gives the disagreements that it finds as texts +// for a failure message, and none when the layout is right. +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open System.Text.Json +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Reflection + +open FSharp.Azure.Cosmos +open FSharp.Azure.Cosmos.Quotations + +/// Assertions on what the layout of the serializer makes of options. +[] +module LayoutAssert = + + /// + /// The layout of ; fails when the layout refuses them, with the reasons. + /// + let WantLayout (options : JsonSerializerOptions) : IJsonLayout = + match JsonLayout.ofSerializerOptions options with + | Result.Ok layout -> layout + | Result.Error reasons -> + raise ( + AssertFailedException + $"The layout should support the options, but it refuses them:\n%s{String.Join ('\n', reasons)}" + ) + + /// + /// The reasons why the layout refuses ; fails when it makes a layout of them. + /// + let WantRefusals (options : JsonSerializerOptions) : ImmutableArray = + match JsonLayout.ofSerializerOptions options with + | Result.Ok _ -> raise (AssertFailedException "The layout should refuse the options, but it makes a layout of them.") + | Result.Error reasons -> reasons + +/// The steps that a layout gives from one JSON value to another one inside it. +[] +module WrittenSteps = + + /// The steps of a path as a query would write them, for a failure message. + let shown (path : ImmutableArray) : string = + path + |> Seq.map (fun step -> + match step with + | JsonStep.Property name -> $"[\"%s{name}\"]" + | JsonStep.Item index -> $"[%d{index}]" + ) + |> String.concat "" + + /// The JSON value at the end of the steps that start at a value; none when a step leads nowhere. + let valueAt (path : ImmutableArray) (start : JsonElement) : JsonElement voption = + path + |> Seq.fold + (fun (reached : JsonElement voption) (step : JsonStep) -> + reached + |> ValueOption.bind (fun value -> + match step with + | JsonStep.Property name when value.ValueKind = JsonValueKind.Object -> + match value.TryGetProperty name with + | true, found -> ValueSome found + | false, _ -> ValueNone + | JsonStep.Item index when + value.ValueKind = JsonValueKind.Array + && index < value.GetArrayLength () + -> + ValueSome value[index] + | _ -> ValueNone + ) + ) + (ValueSome start) + +/// +/// What says of a value that is no object, compared with +/// the JSON value that the serializer wrote for it. +/// +[] +module WrittenValues = + + /// The type arguments of the first of the generic types that a type is or implements. + let private argumentsOf (definitions : Type seq) (valueType : Type) : Type array voption = + seq { + valueType + yield! valueType.GetInterfaces () + } + |> Seq.tryPick (fun candidate -> + if + candidate.IsGenericType + && definitions + |> Seq.exists (fun definition -> Type.(=) (candidate.GetGenericTypeDefinition (), definition)) + then + ValueSome (candidate.GetGenericArguments ()) + else + ValueNone + ) + + /// The types of the keys and values of a map or a dictionary; no value for any other type. + let private keyAndValueOf (valueType : Type) : struct (Type * Type) voption = + argumentsOf + (seq { + typedefof> + typedefof> + typedefof> + }) + valueType + |> ValueOption.map (fun arguments -> struct (arguments[0], arguments[1])) + + /// The type of the items of a collection; no value for a text and for a type that is no collection. + let private elementOf (valueType : Type) : Type voption = + if Type.(=) (valueType, typeof) then + ValueNone + else + argumentsOf (Seq.singleton typedefof>) valueType + |> ValueOption.map (fun arguments -> arguments[0]) + + /// Whether a type is an enumeration or a nullable of one. + let private isEnumeration (valueType : Type) : bool = + match Nullable.GetUnderlyingType valueType with + | null -> valueType.IsEnum + | underlying -> underlying.IsEnum + + /// The names that the layout has for the members of a type, in the order of the names. + let namesOf (layout : IJsonLayout) (holderType : Type) : string array = + seq { + for dataMember in ModelMembers.ofType holderType do + match layout.MemberName { Holder = holderType; Member = dataMember } with + | ValueSome name -> name + | ValueNone -> () + } + |> Seq.sort + |> Seq.toArray + + /// The names of the properties of a JSON object, in the order of the names. + let propertiesOf (written : JsonElement) : string array = + written.EnumerateObject () + |> Seq.map _.Name + |> Seq.sort + |> Seq.toArray + + /// + /// Where what the layout says of a value differs from what the serializer wrote for it, as texts for a failure + /// message. The kind of the written JSON value says what the layout should say: a number or a string for an + /// enumeration, an array or an object for a tuple, an array for a collection, an object or an array for a map. + /// A value that was not written has no kind, and the layout should not describe it. + /// + let disagreementsAbout + (layout : IJsonLayout) + (named : string) + (memberOfDocument : DocumentMember voption) + (valueType : Type) + (written : JsonElement) + : string seq = seq { + if isEnumeration valueType then + let expected = + match written.ValueKind with + | JsonValueKind.Number -> EnumEncoding.Number + | JsonValueKind.String -> EnumEncoding.String + | _ -> EnumEncoding.NotDescribed + + let said = layout.EnumEncoding (memberOfDocument, valueType) + + if said <> expected then + $"%s{named}: the layout says %A{said} of the enumeration, the document %A{expected}" + elif FSharpType.IsTuple valueType then + let expected = + match written.ValueKind with + | JsonValueKind.Array -> TupleEncoding.Array + | _ -> TupleEncoding.NotDescribed + + let said = layout.TupleEncoding (memberOfDocument, valueType) + + if said <> expected then + $"%s{named}: the layout says %A{said} of the tuple, the document %A{expected}" + else + match keyAndValueOf valueType, elementOf valueType with + | ValueSome (struct (key, value)), _ -> + let expected = + match written.ValueKind with + | JsonValueKind.Object -> MapEncoding.Object (key, value) + | JsonValueKind.Array -> MapEncoding.ArrayOfPairs (key, value) + | _ -> MapEncoding.NotDescribed + + let said = layout.MapEncoding (memberOfDocument, valueType) + + if said <> expected then + $"%s{named}: the layout says %A{said} of the map, the document %A{expected}" + | ValueNone, ValueSome element -> + let expected = + match written.ValueKind with + | JsonValueKind.Array -> CollectionEncoding.Array element + | _ -> CollectionEncoding.NotDescribed + + let said = layout.CollectionEncoding (memberOfDocument, valueType) + + if said <> expected then + $"%s{named}: the layout says %A{said} of the collection, the document %A{expected}" + | ValueNone, ValueNone -> () + } + +/// +/// What says of a union, compared with the JSON value that +/// the serializer wrote for a value of one of its cases. +/// +[] +module WrittenUnions = + + /// Whether a JSON value is a tag. + let private isTag (tag : string) (value : JsonElement) : bool = + value.ValueKind = JsonValueKind.String + && String.Equals (value.GetString (), tag, StringComparison.Ordinal) + + /// Whether a written value has a mark; no answer for the mark that nothing is written for. + let private hasMark (mark : UnionCaseMark) (written : JsonElement) : bool voption = + match mark with + | UnionCaseMark.Tag (path, tag) -> + ValueSome ( + WrittenSteps.valueAt path written + |> ValueOption.exists (isTag tag) + ) + | UnionCaseMark.Unmarked -> ValueNone + + /// The case and the values of the fields of a value of a union. + let caseOf (unionType : Type) (value : objnull) : struct (UnionCaseInfo * objnull array) = + let case, values = FSharpValue.GetUnionFields (value, unionType, true) + struct (case, values) + + /// + /// Where what the layout says of the case of a value differs from what the serializer wrote for the value, as + /// texts for a failure message. The mark of the case has to be in the document and the mark of no other case; the + /// value of every field has to be at its place, written as the serializer writes a value of its type. A field + /// without a value that the serializer left out is not looked for. + /// + let disagreementsAbout + (layout : IJsonLayout) + (options : JsonSerializerOptions) + (memberOfDocument : DocumentMember voption) + (unionType : Type) + (value : objnull) + (written : JsonElement) + : string seq = seq { + let struct (case, values) = caseOf unionType value + let named = $"%s{unionType.Name}.%s{case.Name}, written as %s{written.GetRawText ()}" + + match layout.UnionCaseEncoding (memberOfDocument, case) with + | UnionCaseEncoding.NotDescribed -> $"%s{named}: the layout does not describe the case" + | UnionCaseEncoding.Written (mark, places) -> + if hasMark mark written = ValueSome false then + $"%s{named}: the mark %A{mark} is not in the document" + + for other in FSharpType.GetUnionCases (unionType, true) do + if other.Tag <> case.Tag then + match layout.UnionCaseEncoding (memberOfDocument, other) with + | UnionCaseEncoding.Written (otherMark, _) when hasMark otherMark written = ValueSome true -> + $"%s{named}: the mark of the case %s{other.Name} is in the document too" + | _ -> () + + let fields = case.GetFields () + + if places.Length <> fields.Length then + $"%s{named}: the layout has %d{places.Length} places for %d{fields.Length} fields" + else + for index in 0 .. fields.Length - 1 do + let field = fields[index] + let expected = JsonSerializer.SerializeToElement (values[index], field.PropertyType, options) + + match places[index] with + | UnionFieldPlace.Value path -> + match WrittenSteps.valueAt path written with + | ValueSome found when JsonElement.DeepEquals (found, expected) -> () + // A field without a value can be left out, as a field of a record can. + | ValueNone when expected.ValueKind = JsonValueKind.Null -> () + | _ -> $"%s{named}: the field %s{field.Name} is not at %s{WrittenSteps.shown path}" + | UnionFieldPlace.Members path -> + match WrittenSteps.valueAt path written with + | ValueSome holder when holder.ValueKind = JsonValueKind.Object -> + for dataMember in FSharpType.GetRecordFields (field.PropertyType, true) do + let ofRecord = { Holder = field.PropertyType; Member = dataMember } + + let expected = + JsonSerializer.SerializeToElement ( + dataMember.GetValue values[index], + dataMember.PropertyType, + options + ) + + match layout.MemberName ofRecord with + | ValueSome name -> + match holder.TryGetProperty name with + | true, found when JsonElement.DeepEquals (found, expected) -> () + | _ -> + $"%s{named}: the member %s{dataMember.Name} of the record is not at %s{WrittenSteps.shown path}[\"%s{name}\"]" + | ValueNone -> + $"%s{named}: the layout has no name for the member %s{dataMember.Name} of the record" + | _ -> $"%s{named}: no object is at %s{WrittenSteps.shown path} for the members of the record" + } + + /// What the serializer writes for a value; none when it refuses the type. + let written (options : JsonSerializerOptions) (valueType : Type) (value : objnull) : JsonElement voption = + try + ValueSome (JsonSerializer.SerializeToElement (value, valueType, options)) + with :? NotSupportedException -> + ValueNone + + /// + /// What the serializer writes for each of some values of one type; none when it refuses one of them. System.Text.Json + /// refuses a union when it is to write a value of it, and writes a null without asking what it is a null of, so + /// the union with a case that is null is refused as the other unions are. + /// + let writtenAll + (options : JsonSerializerOptions) + (valueType : Type) + (values : objnull seq) + : struct (objnull * JsonElement) array voption = + let documents = + values + |> Seq.map (fun value -> struct (value, written options valueType value)) + |> Seq.toArray + + if + documents + |> Array.forall (fun (struct (_, document)) -> document.IsSome) + then + documents + |> Array.map (fun (struct (value, document)) -> struct (value, document.Value)) + |> ValueSome + else + ValueNone + + /// A union case by its name. + let caseNamed (unionType : Type) (name : string) : UnionCaseInfo = + FSharpType.GetUnionCases (unionType, true) + |> Array.find (fun case -> String.Equals (case.Name, name, StringComparison.Ordinal))