From 8924a73d269935e724797a191c473005a07813c2 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sun, 11 Oct 2026 16:44:30 +0200 Subject: [PATCH 1/5] 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 2/5] 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 3/5] 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 4/5] 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 5/5] 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: /// ,