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