diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index 46978db5..0f41e6f5 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -12,6 +12,12 @@ ```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 +│ ├── Normalizer.fs – normal form of a quotation +│ ├── Evaluator.fs – value of a part of a quotation that reads no variable +│ ├── Query.fs – functions that say whether a value is a constant or a parameter of the query +│ └── Parameterizer.fs – shape of a quotation, by which its translation is found again, and the values of its parameters ├── src/Cosmos/ – main library (FSharp.Azure.Cosmos) │ ├── SubStatusCodes.fs – documented Cosmos DB sub-status codes │ ├── Cosmos.fs – core types and container extensions @@ -28,6 +34,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 1a0488cc..bb4984ca 100644 --- a/FSharp.Azure.Cosmos.slnf +++ b/FSharp.Azure.Cosmos.slnf @@ -2,7 +2,9 @@ "solution": { "path": "FSharp.Azure.Cosmos.slnx", "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 4ec89bbd..3b8b2185 100644 --- a/FSharp.Azure.Cosmos.slnx +++ b/FSharp.Azure.Cosmos.slnx @@ -10,7 +10,9 @@ + + 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/Evaluator.fs b/src/Cosmos.Quotations/Evaluator.fs new file mode 100644 index 00000000..9814adb9 --- /dev/null +++ b/src/Cosmos.Quotations/Evaluator.fs @@ -0,0 +1,693 @@ +/// +/// Computes the value of a part of a quotation that reads no variable. Such a part does not depend on the document, so +/// its value is known before the query runs and becomes a parameter of the query. +/// +/// +/// +/// The part has to be in the normal form that +/// gives: +/// bindings, pipes and calls of functions with reflected definitions are gone. What is left to compute is done by +/// reflection: reading properties and fields, calling methods and constructors, building and reading tuples, records, +/// unions and arrays, testing a type or a union case, choosing between two branches and applying a captured function. +/// +/// +/// An operator of FSharp.Core that refuses to be called by reflection, such as -, / and the conversions +/// between number types, is computed by the function that FSharp.Core has for operands of any types. +/// +/// +/// Nothing is compiled. Turning a quotation into a delegate costs hundreds of microseconds, a thousand times what +/// reflection costs for a property chain, so a part that holds a function written in the quotation has no value +/// here. +/// +/// +/// A choice computes only the branch that its condition chooses, as compiled code does. && and +/// || are choices, so text.IsSome && text.Value.Length > 0 over a captured option without a +/// value is and raises nothing. +/// +/// +/// A node is computed once. The normalizer writes a value that a bound at every place it is +/// used, as the very same node, and the code computes a bound value once: let made = obj () in (made, made) is +/// a pair of one object, here as in compiled code. +/// +/// +/// One node at two places is one value whatever put it there: one quotation that is spliced into two places, or a +/// tree that is built through the API with one node twice, is computed once as well, where compiled code would run it +/// at each place. For code without side effects the two cannot differ. +/// +/// +module internal FSharp.Azure.Cosmos.Quotations.Evaluator + +open System +open System.Collections.Concurrent +open System.Collections.Frozen +open System.Collections.Generic +open System.Collections.Immutable +open System.Reflection +open System.Runtime.CompilerServices +open FSharp.Quotations +open FSharp.Quotations.DerivedPatterns +open FSharp.Quotations.Patterns +open FSharp.Reflection + +/// A part that has no value without compiling it or without a variable: a function, a variable, a quotation. +exception private NotComputable of part : Expr + +/// The members of a type whatever their accessibility: a record or union of the caller may be internal or private. +[] +let private AnyAccessibility = BindingFlags.Public ||| BindingFlags.NonPublic + +// The reflection functions of FSharp.Core declare the values they take as not null. Null is a value they handle all +// the same: it is what a tuple, a record or a union case holds for a reference that is null, and how a union such as +// option represents its case without fields. These two functions are the one place that says so. +#nowarn "3261" + +/// +/// as the reflection functions of FSharp.Core take them. +/// +let private asValues (values : objnull array) : obj array = values + +/// +/// as the reflection functions of FSharp.Core take it. +/// +let private asValue (value : objnull) : obj = value + +#warnon "3261" + +/// +/// as a function that computes its result once for every key and keeps it for the process. +/// What is kept here is what reflection finds out about a type or a method, which takes microseconds to find and never +/// changes. +/// +let private memoize<'Key, 'Value when 'Key : not null> (create : 'Key -> 'Value) : 'Key -> 'Value = + let results = ConcurrentDictionary<'Key, 'Value>() + // The delegate is created once: a new one for every lookup would be an allocation for every lookup. + let factory = Func<'Key, 'Value> create + fun key -> results.GetOrAdd (key, factory) + +/// The function that builds a tuple of a type from its items. +let private tupleConstructorOf = + memoize (fun (tupleType : Type) -> FSharpValue.PreComputeTupleConstructor tupleType) + +/// The function that takes a tuple of a type apart into its items, also the items beyond the seventh. +let private tupleReaderOf = + memoize (fun (tupleType : Type) -> FSharpValue.PreComputeTupleReader tupleType) + +/// The function that builds a record of a type, also of an anonymous record type, from the values of its fields. +let private recordConstructorOf = + memoize (fun (recordType : Type) -> FSharpValue.PreComputeRecordConstructor (recordType, AnyAccessibility)) + +/// The function that builds a value of a union case from the values of its fields. +let private unionConstructorOf = + memoize (fun (case : UnionCaseInfo) -> FSharpValue.PreComputeUnionConstructor (case, AnyAccessibility)) + +/// The function that reads the tag of a value of a union type. +let private tagReaderOf = + memoize (fun (unionType : Type) -> FSharpValue.PreComputeUnionTagReader (unionType, AnyAccessibility)) + +/// +/// The method that applies a function value of a type to one argument: +/// of that type. +/// +let private invokerOf = + memoize (fun (functionType : Type) -> + functionType.GetMethod ("Invoke", [| FSharpType.GetFunctionElements functionType |> fst |]) + |> nonNull + ) + +/// +/// The generic definition of the method that calls. +/// +let private calledDefinition (call : Expr) : MethodInfo = + match call with + | Call (_, method, _) -> method.GetGenericMethodDefinition () + | _ -> invalidArg (nameof call) $"The quotation is not a call: %A{call}" + +/// +/// An operator of FSharp.Core that refuses to be called by reflection, with the function that stands in for it: +/// the one that the compiler passes to , a call of the operator on integers, as the +/// witness of the operator. Both as generic definitions. +/// +let private operatorWithWitness (template : Expr) : struct (MethodInfo * MethodInfo) = + match template with + | CallWithWitnesses (None, operator, _, [ Lambdas (_, Call (None, witness, _)) ], _) -> + struct (operator.GetGenericMethodDefinition (), witness.GetGenericMethodDefinition ()) + | _ -> invalidArg (nameof template) $"The quotation is not a call of an operator with one witness: %A{template}" + +// FS1204 says that these two functions are for dynamic invocation and not for direct use. Dynamic invocation is what +// they are taken for: the quotations only name them and are never run. +#nowarn "1204" + +/// +/// The function of FSharp.Core that negates a value of any type and raises +/// when the result does not fit. +/// +let private checkedNegation = + calledDefinition <@ LanguagePrimitives.CheckedUnaryNegationDynamic 1 @> + +/// +/// The function of FSharp.Core that converts a value of any type to another type and raises +/// when the value does not fit. +/// +let private checkedConversion = + calledDefinition <@ LanguagePrimitives.CheckedExplicitDynamic 1 @> + +#warnon "1204" + +/// +/// The operators of FSharp.Core that refuse to be called by reflection, by the metadata token of the method, each with +/// the function of FSharp.Core that computes it for operands whose types are known only at run time. +/// +/// +/// +/// These operators are compiled into the code that uses them, and their own methods raise +/// , "Dynamic invocation of op_Subtraction is not supported". For every one +/// of them has a function that does the same for any types: +/// for the built-in number types directly, and for another type through the operator that the type defines. The +/// compiler passes that function to the operator as its witness, which is where the pairs are taken from. +/// +/// +/// The checked operators are paired by hand, because the compiler passes them the unchecked functions: a checked +/// conversion that does not fit must raise, as it does in compiled code. +/// +/// +/// +, *, the comparisons and the mathematical functions are not here: reflection can call them. +/// int is here although it can be called, because its own method fails for an enumeration value. +/// +/// +let dynamicOperators : FrozenDictionary = + seq { + yield! + seq { + <@@ 1 - 1 @@> + <@@ 1 / 1 @@> + <@@ 1 % 1 @@> + <@@ -(1) @@> + <@@ +(1) @@> + <@@ ~~~1 @@> + <@@ 1 &&& 1 @@> + <@@ 1 ||| 1 @@> + <@@ 1 ^^^ 1 @@> + <@@ 1 <<< 1 @@> + <@@ 1 >>> 1 @@> + <@@ byte 1 @@> + <@@ sbyte 1 @@> + <@@ int16 1 @@> + <@@ uint16 1 @@> + <@@ int 1L @@> + <@@ int32 1L @@> + <@@ uint32 1 @@> + <@@ int64 1 @@> + <@@ uint64 1 @@> + <@@ nativeint 1 @@> + <@@ unativeint 1 @@> + <@@ float 1 @@> + <@@ float32 1 @@> + <@@ decimal 1 @@> + <@@ char 1 @@> + } + |> Seq.map operatorWithWitness + + yield struct (calledDefinition <@@ Checked.(~-) 1 @@>, checkedNegation) + + yield! + seq { + <@@ Checked.byte 1 @@> + <@@ Checked.sbyte 1 @@> + <@@ Checked.int16 1 @@> + <@@ Checked.uint16 1 @@> + <@@ Checked.int 1L @@> + <@@ Checked.int32 1L @@> + <@@ Checked.uint32 1 @@> + <@@ Checked.int64 1 @@> + <@@ Checked.uint64 1 @@> + <@@ Checked.nativeint 1 @@> + <@@ Checked.unativeint 1 @@> + <@@ Checked.char 1 @@> + } + |> Seq.map (fun template -> struct (calledDefinition template, checkedConversion)) + } + |> _.ToFrozenDictionary((fun (struct (operator, _)) -> operator.MetadataToken), (fun (struct (_, dynamic)) -> dynamic)) + +/// The module of FSharp.Core, in which the metadata tokens of its operators are unique. +let private coreModule = typeof.Module + +/// +/// The function that stands in for a call of one of the +/// with its type arguments. +/// +[] +type private DynamicCall = { + /// The function of FSharp.Core, made for the types of the operands and of the result. + Function : MethodInfo + /// + /// The enumeration type of the result, when the operator gives one. The functions of FSharp.Core fail for an + /// enumeration type, so they are made for the underlying number type; reflection passes them an enumeration value + /// as its number, and a number that comes back becomes a value of this type again. + /// + ResultEnumeration : Type voption +} + +/// +/// , or the number type under it when it is an enumeration type. +/// +let private numberTypeOf (valueType : Type) : Type = + if valueType.IsEnum then + Enum.GetUnderlyingType valueType + else + valueType + +/// +/// The members of as functions that take the nullable. +/// +/// +/// Reflection has nothing to call a member of a nullable on: a nullable is boxed as its value or, when it has none, as +/// , never as itself. As an argument it can be passed, because there is +/// taken for the nullable without a value. +/// +[] +type private NullableMembers<'Value when 'Value : struct and 'Value : (new : unit -> 'Value) and 'Value :> ValueType> = + + /// + /// of . + /// + static member HasValue (nullable : Nullable<'Value>) : bool = nullable.HasValue + + /// + /// of . + /// + static member Value (nullable : Nullable<'Value>) : 'Value = nullable.Value + + /// + /// of . + /// + static member GetValueOrDefault (nullable : Nullable<'Value>) : 'Value = nullable.GetValueOrDefault () + + /// + /// of . + /// + static member GetValueOrDefault (nullable : Nullable<'Value>, defaultValue : 'Value) : 'Value = + nullable.GetValueOrDefault defaultValue + + /// + /// of . + /// + static member Equals (nullable : Nullable<'Value>, other : objnull) : bool = nullable.Equals other + + /// + /// of . + /// + static member GetHashCode (nullable : Nullable<'Value>) : int = nullable.GetHashCode () + + /// + /// of . + /// + static member ToString (nullable : Nullable<'Value>) : string | null = nullable.ToString () + +/// +/// Whether is a member of . +/// +let private isOfNullable (memberOfType : MemberInfo) : bool = + match memberOfType.DeclaringType with + | null -> false + | declaringType -> + // Nearly every member is one of a class, which the first test tells. + declaringType.IsValueType + && declaringType.IsGenericType + && Type.(=) (declaringType.GetGenericTypeDefinition (), typedefof>) + +/// +/// The function that stands in for a method of , also for the getter of a property: +/// the function of the same name that takes the nullable before the arguments of the method. +/// +let private nullableStandInOf = + memoize (fun (method : MethodInfo) -> + let nullableType = nonNull method.DeclaringType + // The getter of a property has the name of the property after "get_". + let name = + if method.IsSpecialName then + method.Name.Substring 4 + else + method.Name + + let parameterTypes = [| + nullableType + for parameter in method.GetParameters () do + parameter.ParameterType + |] + + typedefof> + .MakeGenericType(nullableType.GetGenericArguments ()) + .GetMethod( + name, + BindingFlags.Static + ||| BindingFlags.DeclaredOnly + ||| AnyAccessibility, + parameterTypes + ) + |> nonNull + ) + +/// +/// The function that stands in for a call of a method with its type arguments, when the method is one of the +/// ; no value for a method that is called +/// itself. The type arguments of the function are the types of the operands and then the type of the result, as many +/// as the function takes. +/// +let private dynamicCallOf = + memoize (fun (method : MethodInfo) -> + if method.Module.Equals coreModule then + match dynamicOperators.TryGetValue method.MetadataToken with + | true, dynamic -> + let types = [| + for parameter in method.GetParameters () do + numberTypeOf parameter.ParameterType + numberTypeOf method.ReturnType + |] + + ValueSome { + Function = dynamic.MakeGenericMethod (types |> Array.take (dynamic.GetGenericArguments().Length)) + ResultEnumeration = + if method.ReturnType.IsEnum then + ValueSome method.ReturnType + else + ValueNone + } + | _ -> ValueNone + else + ValueNone + ) + +/// +/// as a value of , as a cast gives it: the value itself when it +/// is of that type, and the exception of a failed cast when it is not. +/// +/// +/// The compiler writes a coercion only where the cast cannot fail, for :> and for an argument that is passed +/// as a base type. A quotation that is built through the API can hold one that fails, and without this check its +/// value would be of another type than the part it is the value of. A cast converts nothing: a boxed integer is no +/// byte, in compiled code either. +/// +let private castTo (targetType : Type) (value : objnull) : objnull = + match value with + | null -> + // Null is a value of every reference type and of a nullable; unboxing it as any other value type fails. + match targetType.IsValueType, Nullable.GetUnderlyingType targetType with + | true, null -> raise (NullReferenceException ()) + | _ -> null + | value when targetType.IsInstanceOfType value -> value + | value -> + raise ( + InvalidCastException + $"Unable to cast object of type '%s{value.GetType().FullName}' to type '%s{targetType.FullName}'." + ) + +/// +/// The values of the nodes of quotations that have been computed, by the identity of the node. The normalizer writes a +/// value that a bound at every place it is used, as the very same node; with the values kept +/// here such a node is computed at the first place that needs its value and never again, as the code computes a +/// bound value once. +/// +/// +/// One of these serves one part, or all the parts of one quotation for a caller that computes several of them: see +/// . +/// +[] +type Computed () = + + // By identity, because a quotation compares and hashes itself by walking all of itself. Made when the first value + // is kept: a part that is a captured value keeps none. + let mutable values : Dictionary | null = null + + /// + /// The value of , when it has been computed. + /// + member _.TryFind (node : Expr) : objnull voption = + match values with + | null -> ValueNone + | values -> + match values.TryGetValue node with + | true, value -> ValueSome value + | _ -> ValueNone + + /// + /// Remembers that has . + /// + member _.Add (node : Expr, value : objnull) : unit = + match values with + | null -> + let created = Dictionary ReferenceEqualityComparer.Instance + created.Add (node, value) + values <- created + | values -> values.Add (node, value) + +/// +/// , the value that a member is called on or that is applied as a function. When it is null, +/// this raises what compiled code raises for it, and not what reflection raises for a call on nothing. +/// +/// +/// Compiled code computes the arguments of a call before it finds that the receiver is null, so this is asked after +/// the arguments are computed: when one of them raises, its exception is the one that the code raises. +/// +let private called (target : objnull) : obj = + match target with + | null -> raise (NullReferenceException ()) + | target -> target + +/// +/// as a member takes its receiver: the value for a member of a value, checked with +/// , and for a +/// static member. +/// +let private calledOn (receiver : Expr option) (target : objnull) : objnull = + match receiver with + | None -> null + | Some _ -> called target + +/// +/// The value of . Exceptions of the code it runs come out as they are raised, mostly wrapped +/// in a . +/// +/// +/// What has been computed so far: the value of a node that is in it is taken from it, and the value of every other +/// node that runs code is added to it. +/// +/// The part to compute. +let rec private valueOf (computed : Computed) (expr : Expr) : objnull = + match expr with + | Value (value, _) -> value + | _ -> + match computed.TryFind expr with + | ValueSome value -> value + | ValueNone -> + let value = computedValueOf computed expr + computed.Add (expr, value) + value + +/// +/// The value of a node that is no value written in the quotation: what its code gives now. +/// +and private computedValueOf (computed : Computed) (expr : Expr) : objnull = + match expr with + | PropertyGet (receiver, property, arguments) -> + match receiver with + | Some nullable when isOfNullable property -> nullableMember computed (nonNull property.GetMethod) nullable arguments + | _ -> + let target = receiverOf computed receiver + let values = valuesOf computed arguments + property.GetValue (calledOn receiver target, values) + | FieldGet (receiver, field) -> field.GetValue (calledOn receiver (receiverOf computed receiver)) + | Call (None, method, arguments) -> + match dynamicCallOf method with + | ValueSome dynamic -> + match dynamic.ResultEnumeration, dynamic.Function.Invoke (null, valuesOf computed arguments) with + | ValueSome enumeration, (NonNull number) -> Enum.ToObject (enumeration, number) + | _, result -> result + | ValueNone -> method.Invoke (null, valuesOf computed arguments) + | Call (receiver, method, arguments) -> + match receiver with + | Some nullable when isOfNullable method -> nullableMember computed method nullable arguments + | _ -> + let target = receiverOf computed receiver + let values = valuesOf computed arguments + method.Invoke (calledOn receiver target, values) + | IfThenElse (condition, whenTrue, whenFalse) -> + if valueOf computed condition :?> bool then + valueOf computed whenTrue + else + valueOf computed whenFalse + | NewObject (constructor, arguments) -> constructor.Invoke (valuesOf computed arguments) + | NewTuple items -> tupleConstructorOf expr.Type (asValues (valuesOf computed items)) + | NewRecord (recordType, items) -> recordConstructorOf recordType (asValues (valuesOf computed items)) + | NewUnionCase (case, items) -> unionConstructorOf case (asValues (valuesOf computed items)) + | NewArray (elementType, items) -> + let array = Array.CreateInstance (elementType, items.Length) + items + |> List.iteri (fun index item -> array.SetValue (valueOf computed item, index)) + array + | TupleGet (tuple, index) -> (tupleReaderOf tuple.Type (asValue (valueOf computed tuple)))[index] + | UnionCaseTest (union, case) -> tagReaderOf case.DeclaringType (asValue (valueOf computed union)) = case.Tag + | TypeTest (value, tested) -> tested.IsInstanceOfType (valueOf computed value) + | Coerce (value, targetType) -> castTo targetType (valueOf computed value) + | DefaultValue valueType -> + // The zeroed value of a struct, for which no constructor runs: a struct of another language can declare a + // constructor without parameters, and the default value is not what that constructor makes. A nullable + // without a value is null as an object, like the default value of a class. + match Nullable.GetUnderlyingType valueType with + | null when valueType.IsValueType -> RuntimeHelpers.GetUninitializedObject valueType + | _ -> null + | Application (func, argument) -> + let target = valueOf computed func + let value = valueOf computed argument + (invokerOf func.Type).Invoke(called target, [| value |]) + | _ -> raise (NotComputable expr) + +/// +/// The value of the receiver of a member, for a static member and for a receiver that is null. +/// +and private receiverOf (computed : Computed) (receiver : Expr option) : objnull = + match receiver with + | None -> null + | Some receiver -> valueOf computed receiver + +/// +/// The value of a member of a nullable. The nullable is passed to the function that stands in for the member, so a +/// nullable without a value is one, and not a receiver that is null. +/// +and private nullableMember (computed : Computed) (method : MethodInfo) (nullable : Expr) (arguments : Expr list) : objnull = + (nullableStandInOf method).Invoke(null, [| valueOf computed nullable; yield! valuesOf computed arguments |]) + +/// The values of the arguments of a member, in their order. +and private valuesOf (computed : Computed) (arguments : Expr list) : objnull array = + arguments |> List.map (valueOf computed) |> List.toArray + +/// +/// The parts of quotations that +/// +/// has refused, by their identity. A caller that asks about a part and +/// then about the parts under it keeps one of these for all its questions: to refuse a part, every part on the way +/// down to the reason was looked at, and is not looked at again. +/// +[] +type Refused () = + + // By identity, because a quotation compares and hashes itself by walking all of itself. + let parts = HashSet ReferenceEqualityComparer.Instance + + /// + /// Whether has been refused. + /// + member _.Holds (part : Expr) : bool = parts.Contains part + + /// + /// Remembers that is refused. + /// + member _.Add (part : Expr) : unit = parts.Add part |> ignore + +/// +/// Whether is made only of what +/// +/// computes. Such a part reads no variable and holds no function that is written in the quotation, so it has a value +/// before the query runs, unless the code in it raises an exception. +/// +/// +/// The answer is given without running any code of the part: a caller asks it to choose the parts to compute, and a +/// part that turned out not to be computable half way would have run a half of its code for nothing. +/// +/// +/// The parts refused so far. A part that is refused now is added, with every part between it and the reason. +/// +/// The part of a quotation in normal form. +let rec canEvaluate (refused : Refused) (expr : Expr) : bool = + not (refused.Holds expr) + && (let can = + match expr with + | Var _ -> false + | Value _ + | DefaultValue _ -> true + | PropertyGet (receiver, _, arguments) + | Call (receiver, _, arguments) -> + receiver |> Option.forall (canEvaluate refused) + && arguments |> List.forall (canEvaluate refused) + | IfThenElse (condition, whenTrue, whenFalse) -> + canEvaluate refused condition + && canEvaluate refused whenTrue + && canEvaluate refused whenFalse + | FieldGet (receiver, _) -> receiver |> Option.forall (canEvaluate refused) + | NewObject (_, items) + | NewRecord (_, items) + | NewUnionCase (_, items) + | NewArray (_, items) + | NewTuple items -> items |> List.forall (canEvaluate refused) + | TupleGet (value, _) + | UnionCaseTest (value, _) + | TypeTest (value, _) + | Coerce (value, _) -> canEvaluate refused value + | Application (func, argument) -> canEvaluate refused func && canEvaluate refused argument + | _ -> false + + if not can then + refused.Add expr + + can) + +/// +/// The error for a part that raised while it was computed. +/// +let private failed (part : Expr) (cause : exn) : TranslationError = + part + |> TranslationError.ofException + TranslationErrorCode.ClientEvaluationFailed + $"A part of the quotation that reads nothing of the document has to be computed before the query runs, and computing it raised %s{cause.GetType().Name}: %s{cause.Message}" + (ImmutableArray.Create + "Compute the value before the quotation, where the exception can be handled, and use the result in the quotation.") + cause + +/// +/// The error for a part that has no value without compiling it. +/// +let private notComputable (part : Expr) : TranslationError = + part + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + "A part of the quotation that reads nothing of the document has to be computed before the query runs, but it holds a function, a variable or another quotation, which cannot be computed without compiling the quotation." + (ImmutableArray.Create "Compute the value before the quotation and use the result in the quotation.") + +/// +/// The value of or the error that says why it has none, with for +/// the nodes that were computed before. +/// +let private evaluate (computed : Computed) (expr : Expr) : Result = + try + Ok (valueOf computed expr) + with + | NotComputable part -> Error (notComputable part) + | :? TargetInvocationException as invocation -> + match invocation.InnerException with + | null -> Error (failed expr invocation) + | cause -> Error (failed expr cause) + | cause -> Error (failed expr cause) + +/// +/// The value of , a part of a quotation in normal form that reads no variable, or the error +/// that says why it has none. A node that stands at several places of the part is computed once. +/// +/// +/// +/// The code of the part raised an exception: +/// with the exception as +/// its . Any exception is taken, because the code +/// is the caller's and may raise any. +/// The part holds a function, a variable or another quotation: +/// . +/// +/// +let tryEvaluate (expr : Expr) : Result = evaluate (Computed ()) expr + +/// +/// for a +/// caller that computes several parts of one quotation: a node that was computed for an earlier part is not computed +/// again for this one. +/// +/// What has been computed so far; what is computed now is added. +/// A part of a quotation in normal form that reads no variable. +let tryEvaluateOnce (computed : Computed) (expr : Expr) : Result = evaluate computed expr diff --git a/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj new file mode 100644 index 00000000..c907c6c6 --- /dev/null +++ b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj @@ -0,0 +1,38 @@ + + + + net10.0 + $(AssemblyBaseName).Quotations + true + true + + + false + + + + true + true + + + + + + + + + + + + + + + all + runtime; build; native; contentfiles; analyzers; buildtransitive + + + + 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/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 diff --git a/src/Cosmos.Quotations/Parameterizer.fs b/src/Cosmos.Quotations/Parameterizer.fs new file mode 100644 index 00000000..152f0c55 --- /dev/null +++ b/src/Cosmos.Quotations/Parameterizer.fs @@ -0,0 +1,943 @@ +namespace FSharp.Azure.Cosmos.Quotations + +open System +open System.Collections.Immutable +open System.Reflection +open System.Text +open FSharp.Quotations +open FSharp.Quotations.ExprShape +open FSharp.Quotations.Patterns +open FSharp.Reflection + +/// +/// What a says about the node of a quotation it stands for. +/// +type internal ShapeTokenKind = + /// A variable that the quotation binds. The number says how many bindings lie between the variable and its own. + | Variable = 0 + /// A function written in the quotation. The subject is the type of its variable. + | Lambda = 1 + /// A delegate written in the quotation. The subject is the type of the delegate, the number counts its variables. + | NewDelegate = 2 + /// A value that is a part of the text of the query. The subject is its type, the detail the value. + | Constant = 3 + /// + /// A . The number is its index, the subject its type and the + /// detail the name of the captured variable, when it has one. + /// + | Slot = 4 + /// The value a type has before anything is assigned. The subject is the type. + | DefaultValue = 5 + /// A union case that is built. The subject is the case. + | NewUnionCase = 6 + /// A tuple that is built. The subject is the type of the tuple, which tells a struct tuple from a reference tuple. + | NewTuple = 7 + /// A record that is built. The subject is the type of the record. + | NewRecord = 8 + /// An array that is built. The subject is the type of its items, the number counts them. + | NewArray = 9 + /// A value seen as a value of another type. The subject is that type. + | Coerce = 10 + /// A choice between two branches. + | IfThenElse = 11 + /// A call of a method. The subject is the method, with its type arguments. + | Call = 12 + /// A reading of a property. The subject is the property. + | PropertyGet = 13 + /// A reading of a field. The subject is the field. + | FieldGet = 14 + /// A call of a constructor. The subject is the constructor. + | NewObject = 15 + /// A reading of an item of a tuple. The number is the index of the item. + | TupleGet = 16 + /// A test for a union case. The subject is the case. + | UnionCaseTest = 17 + /// A test for a type. The subject is the type. + | TypeTest = 18 + /// An application of a function value to an argument. + | Application = 19 + +/// +/// One node of a quotation, as a keeps it: the kind of the +/// node and what tells it from another node of that kind. The nodes under it follow it in the key. +/// +/// +/// Two tokens are equal when they say the same about a node. A member, a type and a union case are compared the way +/// reflection compares them, a constant by its value. A floating-point constant is compared bit by bit, because +/// 0.0 and -0.0 are equal as numbers and are written differently in the text of a query. +/// +[] +type internal ShapeToken = { + /// What the token says about its node. + Kind : ShapeTokenKind + /// The number that the kind gives a meaning to; 0 for a kind that has none. + Number : int + /// + /// The member, type or union case that the kind gives a meaning to; for a kind that + /// has none. + /// + Subject : objnull + /// + /// The value of a constant or the name of a slot; for a kind that has neither, for the + /// constant and for a slot without a name. + /// + Detail : objnull +} with + + /// + /// Whether and are the same token. + /// + static member private AreSame (first : ShapeToken, second : ShapeToken) : bool = + let sameDetail = + match first.Detail, second.Detail with + | (:? float as first), (:? float as second) -> + BitConverter.DoubleToInt64Bits first = BitConverter.DoubleToInt64Bits second + | (:? float32 as first), (:? float32 as second) -> + BitConverter.SingleToInt32Bits first = BitConverter.SingleToInt32Bits second + | first, second -> Object.Equals (first, second) + + first.Kind = second.Kind + && first.Number = second.Number + && Object.Equals (first.Subject, second.Subject) + && sameDetail + + /// + override token.Equals (other : objnull) : bool = + match other with + | :? ShapeToken as other -> ShapeToken.AreSame (token, other) + | _ -> false + + /// + override token.GetHashCode () : int = HashCode.Combine (int token.Kind, token.Number, token.Subject, token.Detail) + + /// The token as text, for the message of a failed assertion and for a debugger. + override token.ToString () : string = + let text = StringBuilder (string token.Kind) + + if + token.Number <> 0 + || token.Kind = ShapeTokenKind.Variable + || token.Kind = ShapeTokenKind.Slot + then + text.Append(' ').Append(token.Number) |> ignore + + match token.Subject with + | null -> () + | subject -> text.Append(' ').Append(subject) |> ignore + + match token.Kind, token.Detail with + | ShapeTokenKind.Constant, detail -> text.Append(" = ").Append($"%A{detail}") |> ignore + | _, null -> () + | _, detail -> text.Append(' ').Append(detail) |> ignore + + text.ToString () + + interface IEquatable with + + /// + member token.Equals (other : ShapeToken) : bool = ShapeToken.AreSame (token, other) + +/// +/// The shape of a quotation: everything in it that decides the text of the query, and nothing that only decides the +/// values of the parameters. Two quotations with equal keys give the same text, so the second one does not have to be +/// translated again. +/// +/// +/// +/// A quotation cannot be its own key. It compares its variables by identity, and every evaluation of a quotation +/// literal creates new variables, so no two evaluations of one literal are equal. It also compares the values it +/// captured, which are what a key has to leave out. +/// +/// +/// The key is the list of the nodes of the quotation, every node before the nodes under it. A variable is in it as +/// the distance to its binding, so the names of variables do not matter. A +/// is in it as its index, type and name, without its value. +/// +/// +[] +type internal ShapeKey = { + /// The nodes of the quotation, every node before the nodes under it. + Tokens : ImmutableArray + /// The hash code of the tokens, computed once when the key is made. + Hash : int +} with + + /// + /// Whether and are the same key. + /// + static member private AreSame (first : ShapeKey, second : ShapeKey) : bool = + // Spans, because the key that no code has filled holds an array that is not there, which a span reads as empty. + first.Hash = second.Hash + && MemoryExtensions.SequenceEqual (first.Tokens.AsSpan (), second.Tokens.AsSpan ()) + + /// + override key.Equals (other : objnull) : bool = + match other with + | :? ShapeKey as other -> ShapeKey.AreSame (key, other) + | _ -> false + + /// + override key.GetHashCode () : int = key.Hash + + /// The tokens as text, one on a line, for the message of a failed assertion and for a debugger. + override key.ToString () : string = + let text = StringBuilder () + + for token in key.Tokens.AsSpan () do + text.Append(token.ToString ()).Append('\n') |> ignore + + text.ToString () + + interface IEquatable with + + /// + member key.Equals (other : ShapeKey) : bool = ShapeKey.AreSame (key, other) + +/// +/// A place in a query for a value that is known before the query runs and is not a part of its text: a value that the +/// quotation captured from the code around it, or the value of a part of the quotation that reads nothing of the +/// document. The parameters of the query are made of the values of its slots. +/// +[] +type internal Slot = { + /// + /// The variable that stands for the value in the . + /// Its type is the type of the value. + /// + Variable : Var + /// The name of the captured variable that the value comes from; none for a value that is computed. + Name : string voption +} + +/// +/// What is known about a quotation without translating it: its +/// , by which a translation made earlier is found, and the +/// values to run that translation with. +/// +[] +type internal Shape = { + /// The shape of the quotation. + Key : ShapeKey + /// + /// The value of every , by the index of the slot. A slot has no + /// value when the quotation computes it only in a branch that it does not take this time: the query does not + /// take that branch either, so whatever stands in for the value there changes no result. + /// + Values : ImmutableArray +} + +/// +/// A quotation prepared for translation: what its holds, and the +/// quotation itself with a variable at every place where a value goes into the query as a parameter. +/// +[] +type internal Template = { + /// The shape of the quotation. + Key : ShapeKey + /// + /// The value of every slot, by the index of the slot: see + /// . + /// + Values : ImmutableArray + /// + /// The quotation with the variable of a at every place of a + /// value that is a parameter. Every value that is left in it is a part of the text of the query. + /// + Body : Expr + /// The slots, by their index. + Slots : ImmutableArray +} + +/// +/// Tells the shape of a quotation from the values it was written with: which values are parameters of the query, what +/// their values are this time, and what is left as the . +/// +/// +/// +/// The quotation has to be in the normal form that +/// gives. +/// +/// +/// These are the rules. +/// +/// +/// A literal is a part of the text of the query, and so of the key: a boolean, a character, a +/// string, an integer or a finite floating-point number of a built-in type, a value of an enumeration, the unit value +/// and . A value of one of these types that is declared with +/// is such a literal, because the compiler writes it into the +/// quotation as one. NaN and the infinities are no literals: the text of a query has no such number, so +/// they are slots. +/// A decimal is not a literal, however it is written: the compiler writes 18m as a call +/// that makes the decimal, so it is computed like any call and is a slot. A parameter keeps its digits; a number in +/// the text of a query is read as a floating-point number. +/// A captured value is a named after its +/// variable. A value of another type that code put into a quotation it built is a slot without a +/// name. +/// A part that +/// +/// accepts, the largest one at its place, is computed and is a slot without a name: a property of a captured value, a +/// call, a module-level value. +/// A tuple, record, union case or array that the quotation builds stays what it is, with its parts +/// handled on their own, even when no part reads the document. The translator has to see that Some limit is an +/// option with a value, and that a list is written item by item. +/// and +/// say the opposite for their argument. A +/// constant has to be a value of one of the types of a literal: the key holds it, and equal keys have to mean one +/// text. +/// +/// +/// A slot stands for one node of the quotation, at every place the node is at. A value that a +/// bound is such a node: the normalizer writes the bound node at every place the value is used. +/// So the value is one slot, and its code runs once, as it does in compiled code, also when the places are inside +/// two different parts that are computed: in let limit = read () in p.Age > limit + 1 || p.Age < limit + 2 +/// both sums are slots of their own, and read is called once. One node at two places is one slot whatever put it +/// there: one quotation that is spliced into two places is one slot for both, with one value. +/// +/// +/// A captured variable that is used at several places is a slot at each of them. The compiler writes every use as a +/// node of its own, and nothing in those nodes says that they are one variable: two quotations that are spliced +/// together can each have captured a variable of the same name. Their values must not say it either. Were two such +/// nodes one slot whenever they hold one value, the key would depend on whether two values happen to be equal this +/// time, and one query would have two texts. A value that has to be one parameter is bound by a +/// inside the quotation. +/// +/// +/// A choice whose condition is known before the query runs computes only the parts of the branch it takes, as compiled +/// code does: in filter.IsNone || p.Name = filter.Value.Trim () nothing is trimmed when there is no filter. The +/// parts of the other branch are slots without a value. The key does not depend on which branch is taken. +/// +/// +[] +module internal Parameterizer = + + /// The reason a quotation has no shape, on its way out of the walk over the quotation. + [] + type private Refusal (error : TranslationError) = + inherit Exception (error.Message) + + /// The reason. + member _.Error = error + + /// + /// What a function of says about its argument. + /// + [] + type private Marker = + /// The argument is a part of the text of the query. + | AsConstant + /// The argument is a parameter of the query. + | AsParameter + + /// + /// The generic definition of the method that calls. + /// + let private calledDefinition (call : Expr) : MethodInfo = + match call with + | Call (None, method, _) -> method.GetGenericMethodDefinition () + | _ -> invalidArg (nameof call) $"The quotation is not a call of a function: %A{call}" + + /// + /// . + /// + let private constantFunction = calledDefinition <@ Query.constant 0 @> + + /// + /// . + /// + let private parameterFunction = calledDefinition <@ Query.parameter 0 @> + + /// + /// What says about its argument, when it is a function of + /// that says something. + /// + [] + let private (|MarkerFunction|_|) (method : MethodInfo) : Marker voption = + // The declaring type is compared first: it is one reference comparison, and it fails for nearly every method. + if Type.(=) (method.DeclaringType, constantFunction.DeclaringType) then + let token = method.MetadataToken + + if token = constantFunction.MetadataToken then + ValueSome AsConstant + elif token = parameterFunction.MetadataToken then + ValueSome AsParameter + else + ValueNone + else + ValueNone + + /// + /// Whether the compiler could have written into a quotation as a literal of the type + /// . Any other value without a name was put there by code that builds quotations, and + /// that code has no other way to pass data, so the value is taken for data. + /// + /// + /// The declared type decides, and not the type of the value: a nullable with a value is boxed as that value, and a + /// nullable without one is a null. So is a case of a union that is represented by null, as the None of an option + /// is. The compiler writes none of them as a value: a case of a union it writes as a case. + /// + let private isLiteral (value : objnull) (declared : Type) : bool = + match value with + // The null of a reference type that is no union, and the unit value. + | null -> + not declared.IsValueType + && not (FSharpType.IsUnion (declared, true)) + | _ -> + // An enumeration has the type code of the number under it, and a nullable has the one of an object. There + // is no decimal here: the compiler never writes one as a value. + match Type.GetTypeCode declared with + | TypeCode.Boolean + | TypeCode.Char + | TypeCode.String + | TypeCode.SByte + | TypeCode.Byte + | TypeCode.Int16 + | TypeCode.UInt16 + | TypeCode.Int32 + | TypeCode.UInt32 + | TypeCode.Int64 + | TypeCode.UInt64 -> true + // The text of a query has no NaN and no infinity: its numbers are decimal or hexadecimal. + | TypeCode.Single -> Single.IsFinite (Convert.ToSingle value) + | TypeCode.Double -> Double.IsFinite (Convert.ToDouble value) + | _ -> false + + /// + /// Whether is the type of F# functions or a class made of it, as the class of every + /// compiled function is and as a class that code declares can be. + /// + let rec private isFunctionClass (valueType : Type | null) : bool = + match valueType with + | null -> false + | valueType -> + (valueType.IsGenericType + && Type.(=) (valueType.GetGenericTypeDefinition (), typedefof<_ -> _>)) + || isFunctionClass valueType.BaseType + + /// + /// Whether a value of is a function or a delegate. + /// + let private isFunction (valueType : Type) : bool = + // A function and a delegate are objects, so a value type is neither, and nearly every slot is of one or a string. + not valueType.IsValueType + && (typeof.IsAssignableFrom valueType + || isFunctionClass valueType) + + /// + /// Whether a part of the type has a function or a delegate as its + /// although its type does not say so. Only an object and an interface can hold one + /// unseen, so a value of any other type is not looked at. + /// + let private isHiddenFunction (valueType : Type) (value : objnull) : bool = + (Type.(=) (valueType, typeof) || valueType.IsInterface) + && ( + match value with + | null -> false + | value -> isFunction (value.GetType ()) + ) + + /// + /// The error for a function value that would have to be a parameter of the query. + /// + let private functionValue (part : Expr) : TranslationError = + part + |> TranslationError.ofQuotation + TranslationErrorCode.CapturedFunctionValue + "A function that exists only as a compiled value is passed into the query. A query cannot use it, because its definition cannot be read, and a function is not a value that a parameter of a query can hold." + (ImmutableArray.Create( + "Mark the function with [], so that its definition can be read.", + "Or write the function as a quotation and splice it into the query with %." + )) + + /// + /// The error for an argument of a function of that is not + /// known before the query runs. + /// + let private notKnownBefore (marker : Marker) (call : Expr) : TranslationError = + let name = + match marker with + | AsConstant -> nameof Query.constant + | AsParameter -> nameof Query.parameter + + call + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + $"The argument of Query.%s{name} has to be known before the query runs, but it reads the document or holds a function written in the quotation." + (ImmutableArray.Create $"Pass Query.%s{name} a value that does not depend on the document.") + + /// + /// The error for an argument of that cannot + /// be written into the text of a query as a literal. + /// + let private notLiteral (valueType : Type) (call : Expr) : TranslationError = + call + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + $"The argument of Query.constant has to be a value that a query can hold as a literal: a boolean, a character, a string, an integer or a finite floating-point number of a built-in type, a value of an enumeration, or the null of a reference type that is no union of F#, as an option is. This one is a %s{valueType.Name}." + (ImmutableArray.Create + "Use the value without Query.constant: it becomes a parameter of the query, which holds a value of any type.") + + /// + /// The error for a variable that nothing in the quotation binds. + /// + let private unbound (variable : Var) (part : Expr) : TranslationError = + part + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + $"The quotation reads the variable '%s{variable.Name}', which nothing in it binds, so the variable has no value." + (ImmutableArray.Create + "Bind the variable with a function around the part that reads it, or put its value into the quotation.") + + /// + /// The error for a construct that is in no quotation in normal form except as a part that is not computed. + /// + let private inexpressible (part : Expr) : TranslationError = + part + |> TranslationError.ofQuotation + TranslationErrorCode.Unsupported + "A query cannot express this part of the quotation: it is neither a value known before the query runs nor an operation on the document." + ImmutableArray.Empty + + /// + /// A slot that the walk has found. + /// + [] + type private Found = { + /// The part of the quotation that the slot stands for, by which another use of the very same part is told. + Part : Expr + /// The name of the captured variable; none for a value that is computed. + Name : string voption + /// The type of the value. + Type : Type + } + + /// + /// One walk over a quotation. It writes the tokens of the key and collects the slots with their values; when + /// is set, it also builds the quotation with a variable at the place of every slot. + /// + /// + /// Both results come from one walk, so that the key of a quotation is the same whether or not it is rebuilt. + /// Rebuilding is left out when the key is all that is asked for: building a node of a quotation costs microseconds, + /// and a quotation whose translation is already known needs no node built. + /// + [] + type private Walk (rebuild : bool) = + + let tokens = ImmutableArray.CreateBuilder 32 + let mutable hash = HashCode () + let values = ImmutableArray.CreateBuilder 4 + let found = ResizeArray 4 + let slots = ImmutableArray.CreateBuilder() + // The variables that the functions around the current node bind, the innermost one last. + let bound = ResizeArray 4 + // The nodes from the quotation down to the current node. When the walk is left, it tells where it was. + let path = ResizeArray 16 + // The parts that the evaluator has refused. The walk asks about a part and then about the parts under it, and + // the evaluator went down those parts to refuse the first one, so it answers for them from here. + let refused = Evaluator.Refused () + // What the walk has computed, node by node, so that a node that stands at several places is computed once, + // also when the places are inside different parts. + let computed = Evaluator.Computed () + // The node that was made a slot last, and the index of that slot: how a choice knows its condition. + let mutable latestPart : Expr | null = null + let mutable latestValue : objnull voption = ValueNone + + /// Writes a token into the key. + let emit (kind : ShapeTokenKind) (number : int) (subject : objnull) (detail : objnull) : unit = + let token = { Kind = kind; Number = number; Subject = subject; Detail = detail } + + tokens.Add token + hash.Add token + + /// Whether a part can be computed before the query runs. + let canCompute (part : Expr) : bool = Evaluator.canEvaluate refused part + + /// The value of a part that reads nothing of the document; leaves the walk when the code of the part raises. + let compute (part : Expr) : objnull = + match Evaluator.tryEvaluateOnce computed part with + | Ok value -> value + | Error error -> raise (Refusal error) + + /// The index of the slot that stands for this very part, or -1. + let indexOf (part : Expr) : int = + let mutable index = found.Count - 1 + + while index >= 0 + && not (obj.ReferenceEquals (found[index].Part, part)) do + index <- index - 1 + + index + + /// + /// The type of the value of a part that becomes a slot or a constant. A function is refused here, before + /// anything is computed for it. + /// + let valueTypeOf (part : Expr) : Type = + let valueType = part.Type + + if isFunction valueType then + raise (Refusal (functionValue part)) + + valueType + + /// + /// , the value of a part that becomes a slot or a constant. A function that is passed + /// as an object is refused here: the type of the part did not say what it is. + /// + let noFunction (part : Expr) (valueType : Type) (value : objnull) : objnull = + if isHiddenFunction valueType value then + raise (Refusal (functionValue part)) + + value + + /// The index of a new slot. + let add (part : Expr) (valueType : Type) (name : string voption) (value : objnull voption) : int = + let index = found.Count + + found.Add { Part = part; Name = name; Type = valueType } + + values.Add value + + if rebuild then + let variableName = + match name with + | ValueSome name -> name + | ValueNone -> $"p%d{index}" + + slots.Add { Variable = Var (variableName, valueType); Name = name } + + index + + /// + /// The index of the slot of a value that the quotation holds: a captured variable at one of the places it is + /// used at, which has a , or a value that code put into a quotation it built, which + /// has none. Another place is another slot unless it holds this very part: nothing else says that two parts + /// are one variable, and their values must not decide it, or the key would depend on them. + /// + let held (part : Expr) (name : string voption) (value : objnull) : int = + match indexOf part with + | -1 -> + let valueType = valueTypeOf part + add part valueType name (ValueSome (noFunction part valueType value)) + | index -> index + + /// + /// The index of the slot of a part that is computed. The part is computed when says + /// that the quotation takes the branch it is in, and once for all the places the very same part is at. + /// + let computed (live : bool) (part : Expr) : int = + match indexOf part with + | -1 -> + let valueType = valueTypeOf part + + add + part + valueType + ValueNone + (if live then + ValueSome (noFunction part valueType (compute part)) + else + ValueNone) + | index -> + // The part was met before in a branch that is not taken, and is met now where its value is needed. + if live && values[index].IsNone then + values[index] <- ValueSome (noFunction part found[index].Type (compute part)) + + index + + /// Writes the token of a slot; the node that stands at the place of the slot from now on. + let slot (index : int) (node : Expr) : Expr = + let entry = found[index] + + let name : objnull = + match entry.Name with + | ValueSome name -> name + | ValueNone -> null + + emit ShapeTokenKind.Slot index entry.Type name + latestPart <- node + latestValue <- values[index] + + if rebuild then Expr.Var slots[index].Variable else node + + /// Writes the token of a variable: how many bindings lie between the variable and its own. + let variable (bindingOf : Var) (node : Expr) : unit = + let mutable index = bound.Count - 1 + + while index >= 0 + && not (obj.ReferenceEquals (bound[index], bindingOf)) do + index <- index - 1 + + if index < 0 then + raise (Refusal (unbound bindingOf node)) + + emit ShapeTokenKind.Variable (bound.Count - 1 - index) null null + + /// + /// The value of the condition of a choice that has just been walked, when it is known: the condition is a slot + /// with a value. A literal is never a condition in normal form. + /// + let chosen (condition : Expr) : bool voption = + if obj.ReferenceEquals (latestPart, condition) then + match latestValue with + | ValueSome (:? bool as value) -> ValueSome value + | _ -> ValueNone + else + ValueNone + + /// + /// Walks and the nodes under it. says whether the quotation + /// takes the branch the node is in. The result is the node, or the node rebuilt when a slot is under it and + /// the walk rebuilds. + /// + let rec visit (live : bool) (node : Expr) : Expr = + path.Add node + let visited = inspect live node + path.RemoveAt (path.Count - 1) + visited + + /// What a visit does for a node, between entering it and leaving it. + and inspect (live : bool) (node : Expr) : Expr = + // The kinds of nodes that a query is mostly made of come first: every case that does not match costs a + // test, and a node is tested against the cases in their order. + match node with + | Var bindingOf -> + variable bindingOf node + node + | ValueWithName (value, _, name) -> slot (held node (ValueSome name) value) node + | Value (value, valueType) -> + if isLiteral value valueType then + // A literal that is not null is of no function type. A null is the literal of every class, of a + // function type too, and there it is refused as a function is: the query can use neither. + let valueType = + match value with + | null -> valueTypeOf node + | _ -> valueType + + emit ShapeTokenKind.Constant 0 valueType value + node + else + slot (held node ValueNone value) node + | PropertyGet (receiver, property, arguments) -> + if canCompute node then + slot (computed live node) node + else + emit ShapeTokenKind.PropertyGet 0 property null + members live node receiver arguments + | Call (receiver, method, arguments) -> + match method, arguments with + | MarkerFunction marker, [ argument ] -> marked live marker node argument + | _ when canCompute node -> slot (computed live node) node + | _ -> + emit ShapeTokenKind.Call 0 method null + members live node receiver arguments + | IfThenElse (condition, whenTrue, whenFalse) -> + if canCompute node then + slot (computed live node) node + else + emit ShapeTokenKind.IfThenElse 0 null null + let visitedCondition = visit live condition + + // A branch that the quotation does not take is still walked: the key holds both branches, + // whichever is taken this time. + let taken = if live then chosen condition else ValueNone + let visitedWhenTrue = visit (live && taken <> ValueSome false) whenTrue + let visitedWhenFalse = visit (live && taken <> ValueSome true) whenFalse + + if + obj.ReferenceEquals (visitedCondition, condition) + && obj.ReferenceEquals (visitedWhenTrue, whenTrue) + && obj.ReferenceEquals (visitedWhenFalse, whenFalse) + then + node + else + Expr.IfThenElse (visitedCondition, visitedWhenTrue, visitedWhenFalse) + | Lambda (parameter, body) -> + emit ShapeTokenKind.Lambda 0 parameter.Type null + bound.Add parameter + let visited = visit live body + bound.RemoveAt (bound.Count - 1) + + if obj.ReferenceEquals (visited, body) then + node + else + Expr.Lambda (parameter, visited) + | NewUnionCase (case, items) -> + emit ShapeTokenKind.NewUnionCase 0 case null + parts live node items + | NewTuple items -> + emit ShapeTokenKind.NewTuple 0 node.Type null + parts live node items + | NewRecord (recordType, items) -> + emit ShapeTokenKind.NewRecord 0 recordType null + parts live node items + | NewArray (itemType, items) -> + emit ShapeTokenKind.NewArray items.Length itemType null + parts live node items + | Coerce (value, targetType) -> + emit ShapeTokenKind.Coerce 0 targetType null + parts live node [ value ] + | DefaultValue _ -> + // The default value of a function type is the null of it. + emit ShapeTokenKind.DefaultValue 0 (valueTypeOf node) null + node + | NewDelegate (delegateType, parameters, body) -> + emit ShapeTokenKind.NewDelegate parameters.Length delegateType null + bound.AddRange parameters + let visited = visit live body + bound.RemoveRange (bound.Count - parameters.Length, parameters.Length) + + if obj.ReferenceEquals (visited, body) then + node + else + Expr.NewDelegate (delegateType, parameters, visited) + // Every kind of node below is computed as a whole when the evaluator can compute it. + | _ when canCompute node -> slot (computed live node) node + | FieldGet (receiver, field) -> + emit ShapeTokenKind.FieldGet 0 field null + members live node receiver [] + | NewObject (constructor, arguments) -> + emit ShapeTokenKind.NewObject 0 constructor null + parts live node arguments + | TupleGet (tuple, index) -> + emit ShapeTokenKind.TupleGet index null null + parts live node [ tuple ] + | UnionCaseTest (union, case) -> + emit ShapeTokenKind.UnionCaseTest 0 case null + parts live node [ union ] + | TypeTest (value, testedType) -> + emit ShapeTokenKind.TypeTest 0 testedType null + parts live node [ value ] + | Application (func, argument) -> + emit ShapeTokenKind.Application 0 null null + parts live node [ func; argument ] + | _ -> raise (Refusal (inexpressible node)) + + /// + /// Walks the argument of a function of , which says what + /// the argument is. The call itself leaves no trace: it only says how its argument is read. + /// + and marked (live : bool) (marker : Marker) (call : Expr) (argument : Expr) : Expr = + match marker, argument with + | AsParameter, ValueWithName (value, _, name) -> slot (held argument (ValueSome name) value) call + | AsParameter, Value (value, _) -> slot (held argument ValueNone value) call + | AsParameter, _ when canCompute argument -> slot (computed live argument) call + | AsConstant, _ when canCompute argument -> + // The value is a part of the key, so it is computed whichever branch the call is in. + let valueType = valueTypeOf argument + let value = noFunction argument valueType (compute argument) + + // The key holds the value, and equal keys have to mean one text. Only a literal says by its equality + // what is written for it: an object is equal to itself after it has changed, and two objects can be + // equal and be written differently. + if not (isLiteral value valueType) then + raise (Refusal (notLiteral valueType call)) + + emit ShapeTokenKind.Constant 0 valueType value + latestPart <- call + latestValue <- ValueSome value + + if rebuild then Expr.Value (value, valueType) else call + | _ -> raise (Refusal (notKnownBefore marker call)) + + /// Walks the receiver and the arguments of a member. + and members (live : bool) (node : Expr) (receiver : Expr option) (arguments : Expr list) : Expr = + match receiver with + | Some receiver -> parts live node (receiver :: arguments) + | None -> parts live node arguments + + /// + /// Walks , the nodes under in their order. The result is the + /// node, or the node built anew over the items that the walk rebuilt. + /// + and parts (live : bool) (node : Expr) (items : Expr list) : Expr = + if rebuild then + let visited = items |> List.map (visit live) + + if List.forall2 (fun (item : Expr) (after : Expr) -> obj.ReferenceEquals (item, after)) items visited then + node + else + match node with + | ShapeCombination (shape, _) -> RebuildShapeCombination (shape, visited) + | _ -> node + else + for item in items do + visit live item |> ignore + + node + + /// + /// Walks , which the walk has not been used for before; the quotation, rebuilt when the + /// walk rebuilds. + /// + member _.Run (expr : Expr) : Expr = visit true expr + + /// + /// , which the walk was left with, with a place in the source: its own, or the place + /// of the nearest node around the part it is about that has one. A captured value has none of its own, and a + /// node that the normalizer built has the place of a part under it. + /// + member _.Located (error : TranslationError) : TranslationError = + if error.Location.IsSome then + error + else + let mutable index = path.Count - 1 + let mutable place = ValueNone + + while index >= 0 && place.IsNone do + place <- SourceRange.tryOfQuotation path[index] + index <- index - 1 + + { error with Location = place } + + /// The key of the quotation that was walked. + member _.Key : ShapeKey = { Tokens = tokens.ToImmutable (); Hash = hash.ToHashCode () } + + /// The values of the slots of the quotation that was walked. + member _.Values : ImmutableArray = values.ToImmutable () + + /// The slots of the quotation that was walked, when the walk rebuilds. + member _.Slots : ImmutableArray = slots.ToImmutable () + + /// + /// The key of , a quotation in normal form, and the values of its slots, or the reason it + /// has none. This is all that a quotation needs when its translation is known already. + /// + /// + /// These are errors: + /// + /// a part that has to be computed raised an exception, + /// ; + /// a function value would have to be a parameter, + /// ; + /// the argument of a function of depends + /// on the document, the argument of + /// is no value that a query can hold as a + /// literal, a variable is bound nowhere, or the quotation holds a construct that is neither a value nor an + /// operation on the document, . + /// + /// + /// + let shapeOf (expr : Expr) : Result = + let walk = Walk false + + try + walk.Run expr |> ignore + + Ok { Key = walk.Key; Values = walk.Values } + with :? Refusal as refusal -> + Error (walk.Located refusal.Error) + + /// + /// , a quotation in normal form, prepared for translation, or the reason it cannot be: + /// the errors of . + /// The key and the values are the ones that function gives. + /// + let templateOf (expr : Expr) : Result = + let walk = Walk true + + try + let body = walk.Run expr + + Ok { Key = walk.Key; Values = walk.Values; Body = body; Slots = walk.Slots } + with :? Refusal as refusal -> + Error (walk.Located refusal.Error) diff --git a/src/Cosmos.Quotations/Query.fs b/src/Cosmos.Quotations/Query.fs new file mode 100644 index 00000000..cda1fdd7 --- /dev/null +++ b/src/Cosmos.Quotations/Query.fs @@ -0,0 +1,53 @@ +/// +/// Functions that say, inside a quotation, how a value gets into the query. +/// +/// +/// +/// A query is its text and the values of its parameters. A value that a quotation writes as a literal, such as +/// 18 in p.Age > 18, is a part of the text. A value that the quotation takes from the code around it +/// or computes from such values, such as limit in p.Age > limit, is a parameter: the text stays the +/// same when the value changes. +/// +/// +/// The functions here say the opposite for one value. Outside a quotation each of them returns its argument. +/// +/// +[] +module FSharp.Azure.Cosmos.Quotations.Query + +/// +/// Makes a part of the text of the query, although the quotation does not write it as a +/// literal: p.Kind = Query.constant kind. +/// +/// +/// +/// Every different value gives a query with a text of its own, which is translated on its own. So this is for a value +/// that takes few different values, never for a value that a user of the application enters. +/// +/// +/// The value has to be known before the query runs: it cannot depend on the document. And it has to be a value that a +/// query can hold as a literal: a boolean, a character, a string, an integer or a finite floating-point number of a +/// built-in type, a value of an enumeration or the of a reference type. A value of any other +/// type can only be a parameter: a decimal, a date, a number that is not finite, and a nullable or an option, with a +/// value or without one. +/// +/// +/// The value, which the quotation takes from the code around it or computes from such values. +/// . +let constant (value : 'T) : 'T = value + +/// +/// Makes a parameter of the query, although the quotation writes it as a literal: +/// p.Age > Query.parameter 18. +/// +/// +/// +/// Two queries that differ only in such a value have the same text, so the second one is not translated again. +/// +/// +/// The value has to be known before the query runs: it cannot depend on the document. +/// +/// +/// The value. +/// . +let parameter (value : 'T) : 'T = value diff --git a/src/Cosmos.Quotations/TranslationError.fs b/src/Cosmos.Quotations/TranslationError.fs new file mode 100644 index 00000000..a658a454 --- /dev/null +++ b/src/Cosmos.Quotations/TranslationError.fs @@ -0,0 +1,178 @@ +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, or is passed into + /// the query as a value. A compiled function cannot be read, so it cannot become a part of the query, and it is + /// no value that a parameter of a query can hold; a quotation or a function marked with + /// can be read. + /// + | CapturedFunctionValue + /// + /// 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 + /// + /// A part of the quotation that reads nothing of the document has to be computed before the query runs, and + /// computing it failed: the code in it raised an exception, which is the + /// . + /// + | ClientEvaluationFailed + +/// +/// Why a quotation cannot be translated into a query, with the part of the quotation that is the reason. +/// +/// +/// 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 + /// The exception that code of the quotation raised, when that is the reason. + Cause : exn voption +} + +/// +/// 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 + Cause = ValueNone + } + + /// + /// The error with , and about + /// that the exception is the reason of. + /// + let ofException + (code : TranslationErrorCode) + (message : string) + (hints : ImmutableArray) + (cause : exn) + (fragment : Expr) + : TranslationError = { ofQuotation code message hints fragment with Cause = ValueSome cause } + + /// + /// The error with and about a quotation as a whole: it names no + /// part of it. + /// + let ofWhole (code : TranslationErrorCode) (message : string) : TranslationError = { + Code = code + Message = message + Fragment = "" + Location = ValueNone + Hints = ImmutableArray.Empty + Cause = ValueNone + } diff --git a/tests/Cosmos.Quotations.Tests/EvaluatorTests.fs b/tests/Cosmos.Quotations.Tests/EvaluatorTests.fs new file mode 100644 index 00000000..59cde783 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/EvaluatorTests.fs @@ -0,0 +1,659 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open System.Globalization +open System.Reflection +open System.Reflection.Emit +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations +open FSharp.Quotations.Patterns + +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// +/// A value written as code that reads no variable of a quotation: the part of the quotation to compute, and what the +/// compiled code gives for it. +/// +type Computation = { + /// What kind of code computes the value; the name of a test result starts with it. + Name : string + /// The code in the normal form of the normalizer, without the function it was written in. + Part : Expr + /// Fails unless a value is what the compiled code gives. + IsExpected : objnull -> unit +} with + + /// + /// The part of a quotation that computes. The compiler passes the code together with its + /// quotation, so the expected value is what the code gives when it runs. + /// + static member Of<'Result when 'Result : equality> + (name : string, [] code : Expr 'Result>) + : Computation + = + let code = Quoted.Split code + + { + Name = name + Part = Computation.PartOf code.Quotation + IsExpected = + fun value -> + Assert.AreEqual<'Result>( + code.Compiled (), + (value :?> 'Result), + "The evaluator should compute what the compiled code computes." + ) + + // A boxed number can be taken out as an enumeration value, so the cast above does not tell them + // apart, but a parameter of a query is written by the type its value has. + match value with + | null -> () + | value when typeof<'Result>.IsEnum -> + Assert.AreEqual( + typeof<'Result>, + value.GetType (), + "A value of an enumeration type should be of that type, not the number under it." + ) + | _ -> () + } + + /// + /// The body of the function of the unit value that is, in normal form: a part that reads no + /// variable. + /// + static member PartOf (code : Expr) : Expr = + match NormalizerAssert.WantNormal code with + | Lambda (_, part) -> part + | normal -> invalidArg (nameof code) $"The code should be a function of the unit value: %A{normal}" + +/// +/// : the +/// value of a part of a quotation that reads no variable is what the compiled code of that part gives, and an exception +/// of that code is an error with the exception as its cause. +/// +[] +type EvaluatorTests () = + + static let computations = + // Captured by the code below, as a query captures the values it is asked with. + let limit = 30 + let price = 12.5 + let amount = 19.99m + let name = "Bob" + // A date is read as the field of a captured record: the compiler refuses to read a member of a captured local + // of a value type in a quotation (FS3155). + let meeting = {| At = DateTime (2024, 2, 29, 13, 30, 0, DateTimeKind.Utc) |} + let nick = Some "bobby" + let noNick : string option = None + let alias = ValueSome "bo" + let pair = (3, "three") + let structPair = struct (4, "four") + let eight = (1, 2, 3, 4, 5, 6, 7, "eight") + let range = { Low = 18; High = 65 } + let tags = [ "vip"; "new" ] + let filter = OlderThan 18 + let addOne = fun (number : int) -> number + 1 + let add = fun (first : int) (second : int) -> first + second + let wait = {| For = TimeSpan.FromMinutes 90.0 |} + // A nullable is read as the field of a captured record, like the date above. + let optional = {| Limit = Nullable 30; Missing = Nullable() |} + let flags = BindingFlags.Public ||| BindingFlags.Instance + + seq { + // Values and operators + Computation.Of ("a captured value", (fun () -> limit)) + Computation.Of ("a constant", (fun () -> 42)) + Computation.Of ("the sum of a captured value and a constant", (fun () -> limit + 1)) + Computation.Of ("arithmetic on integers", (fun () -> (limit - 4) * 3 / 2 % 7)) + Computation.Of ("the negation of a number", (fun () -> -limit)) + Computation.Of ("arithmetic on floating-point numbers", (fun () -> price * 2.0 + 0.5)) + Computation.Of ("arithmetic on decimals", (fun () -> amount * 2m + 0.01m)) + Computation.Of ("arithmetic on 64-bit integers", (fun () -> int64 limit * 4_000_000_000L)) + Computation.Of ("a conversion to a floating-point number", (fun () -> float limit / 4.0)) + Computation.Of ("a conversion to an integer", (fun () -> int price)) + Computation.Of ("a conversion to a string", (fun () -> string limit)) + Computation.Of ("the concatenation of strings", (fun () -> name + "!")) + Computation.Of ("a comparison", (fun () -> limit > 18)) + Computation.Of ("an equality of strings", (fun () -> name = "Bob")) + Computation.Of ("a negation", (fun () -> not (limit > 18))) + + // Operators that FSharp.Core does not let reflection call + Computation.Of ("a subtraction", (fun () -> limit - 4)) + Computation.Of ("a division", (fun () -> limit / 4)) + Computation.Of ("a remainder", (fun () -> limit % 4)) + Computation.Of ("a division of floating-point numbers", (fun () -> price / 4.0)) + Computation.Of ("a number with a plus sign", (fun () -> +limit)) + Computation.Of ("the complement of the bits of a number", (fun () -> ~~~limit)) + Computation.Of ("a bitwise and", (fun () -> limit &&& 12)) + Computation.Of ("a bitwise or", (fun () -> limit ||| 1)) + Computation.Of ("a bitwise exclusive or", (fun () -> limit ^^^ 5)) + Computation.Of ("a shift to the left", (fun () -> limit <<< 2)) + Computation.Of ("a shift to the right", (fun () -> limit >>> 2)) + Computation.Of ("a conversion to a byte", (fun () -> byte limit)) + Computation.Of ("a conversion to a signed byte", (fun () -> sbyte limit)) + Computation.Of ("a conversion to a 16-bit integer", (fun () -> int16 limit)) + Computation.Of ("a conversion to an unsigned 16-bit integer", (fun () -> uint16 limit)) + Computation.Of ("a conversion to a 32-bit integer", (fun () -> int32 price)) + Computation.Of ("a conversion to an unsigned 32-bit integer", (fun () -> uint32 limit)) + Computation.Of ("a conversion to a 64-bit integer", (fun () -> int64 price)) + Computation.Of ("a conversion to an unsigned 64-bit integer", (fun () -> uint64 limit)) + Computation.Of ("a conversion to a native integer", (fun () -> nativeint limit)) + Computation.Of ("a conversion to an unsigned native integer", (fun () -> unativeint limit)) + Computation.Of ("a conversion to a single-precision number", (fun () -> float32 limit)) + Computation.Of ("a conversion to a decimal", (fun () -> decimal limit)) + Computation.Of ("a conversion to a character", (fun () -> char (limit + 35))) + Computation.Of ("a conversion that cuts the value off", (fun () -> byte (limit * 10))) + Computation.Of ("a checked negation", (fun () -> Checked.(~-) limit)) + Computation.Of ("a checked conversion to a byte", (fun () -> Checked.byte limit)) + Computation.Of ("a checked conversion to a signed byte", (fun () -> Checked.sbyte limit)) + Computation.Of ("a checked conversion to a 16-bit integer", (fun () -> Checked.int16 limit)) + Computation.Of ("a checked conversion to an unsigned 16-bit integer", (fun () -> Checked.uint16 limit)) + Computation.Of ("a checked conversion to a 32-bit integer", (fun () -> Checked.int32 price)) + Computation.Of ("a checked conversion to an unsigned 32-bit integer", (fun () -> Checked.uint32 limit)) + Computation.Of ("a checked conversion to a 64-bit integer", (fun () -> Checked.int64 price)) + Computation.Of ("a checked conversion to an unsigned 64-bit integer", (fun () -> Checked.uint64 limit)) + Computation.Of ("a checked conversion to a native integer", (fun () -> Checked.nativeint limit)) + Computation.Of ("a checked conversion to an unsigned native integer", (fun () -> Checked.unativeint limit)) + Computation.Of ("a checked conversion to a character", (fun () -> Checked.char (limit + 35))) + Computation.Of ("a subtraction of decimals", (fun () -> amount - 0.99m)) + Computation.Of ("a division of a type with its own operator", (fun () -> wait.For / 2.0)) + Computation.Of ("the negation of a type with its own operator", (fun () -> -wait.For)) + Computation.Of ("the number of an enumeration value", (fun () -> int meeting.At.DayOfWeek)) + Computation.Of ("the 64-bit number of an enumeration value", (fun () -> int64 meeting.At.DayOfWeek)) + Computation.Of ("the checked number of an enumeration value", (fun () -> Checked.int meeting.At.DayOfWeek)) + Computation.Of ("the enumeration value of a number", (fun () -> enum(limit - 25))) + Computation.Of ("a combination of flags", (fun () -> BindingFlags.Public ||| BindingFlags.Static)) + Computation.Of ("the flags that two values share", (fun () -> flags &&& BindingFlags.Public)) + Computation.Of ("the complement of flags", (fun () -> ~~~flags)) + Computation.Of ("flags without one of them", (fun () -> flags &&& ~~~BindingFlags.Instance)) + + // Choices, which compute one branch only + Computation.Of ("a choice", (fun () -> if limit > 18 then "adult" else "minor")) + Computation.Of ( + "a conjunction whose second condition would fail", + (fun () -> noNick.IsSome && noNick.Value.Length > 0) + ) + Computation.Of ( + "a disjunction whose second condition would fail", + (fun () -> noNick.IsNone || noNick.Value.Length > 0) + ) + Computation.Of ("a conjunction of two conditions that hold", (fun () -> nick.IsSome && nick.Value.Length > 0)) + + // Members + Computation.Of ("a static field", (fun () -> DateTime.UnixEpoch)) + Computation.Of ("a static property", (fun () -> CultureInfo.InvariantCulture.Name)) + Computation.Of ("a module-level value", (fun () -> Conditions.retirementAge)) + Computation.Of ("a property of a string", (fun () -> name.Length)) + Computation.Of ("a chain of properties", (fun () -> meeting.At.Date.Year)) + Computation.Of ("a method with an argument", (fun () -> meeting.At.AddDays 2.0)) + Computation.Of ("a method of a string", (fun () -> name.ToUpperInvariant().Substring 1)) + Computation.Of ("a static method", (fun () -> Math.Max (limit, 18))) + Computation.Of ("a static method that parses", (fun () -> Guid.Parse "0d8f4b51-7d0d-4c35-9a53-4e0b3a1f6f10")) + Computation.Of ("a generic function", (fun () -> List.length tags)) + Computation.Of ("a function of a module", (fun () -> String.concat "," tags)) + Computation.Of ("a function without a reflected definition", (fun () -> Conditions.isTeenager Persons.child)) + Computation.Of ("a function with a reflected definition that calls itself", (fun () -> Conditions.factorial 5)) + Computation.Of ("a method of a captured record", (fun () -> Persons.retired.IsRetired ())) + Computation.Of ("an operator of a type", (fun () -> (meeting.At - DateTime.UnixEpoch).TotalDays)) + Computation.Of ("a member of an enumeration value", (fun () -> meeting.At.DayOfWeek = DayOfWeek.Thursday)) + + // Values that are built + Computation.Of ("a constructor", (fun () -> DateTime (2020, 1, 2))) + Computation.Of ("a nullable value", (fun () -> Nullable limit)) + Computation.Of ("a tuple", (fun () -> (limit, name))) + Computation.Of ("a struct tuple", (fun () -> struct (limit, name))) + Computation.Of ("a record", (fun () -> { Low = limit; High = 65 })) + Computation.Of ("an anonymous record", (fun () -> {| Name = name; Limit = limit |})) + Computation.Of ("a struct anonymous record", (fun () -> struct {| Name = name; Limit = limit |})) + Computation.Of ("a union case with a field", (fun () -> ByName name)) + Computation.Of ("an option with a value", (fun () -> Some limit)) + Computation.Of ("an option without a value", (fun () -> (None : int option))) + Computation.Of ("a value option with a value", (fun () -> ValueSome name)) + Computation.Of ("a list", (fun () -> [ limit; 1 ])) + Computation.Of ("a default value of a struct", (fun () -> Unchecked.defaultof)) + Computation.Of ("a default value of a class", (fun () -> Unchecked.defaultof)) + Computation.Of ("a struct that is made without arguments", (fun () -> DateTime ())) + Computation.Of ("a nullable without a value", (fun () -> Nullable())) + + // Values that are taken apart + Computation.Of ("the first item of a captured pair", (fun () -> fst pair)) + Computation.Of ("the second item of a captured pair", (fun () -> snd pair)) + Computation.Of ( + "an item of a captured struct tuple", + (fun () -> + let struct (number, _) = structPair + number + ) + ) + Computation.Of ( + "the eighth item of a captured tuple", + (fun () -> + let (_, _, _, _, _, _, _, last) = eight + last + ) + ) + Computation.Of ("a field of a captured record", (fun () -> range.High)) + Computation.Of ( + "a match on a captured option with a value", + (fun () -> + match nick with + | Some text -> text + | None -> "" + ) + ) + Computation.Of ( + "a match on a captured option without a value", + (fun () -> + match noNick with + | Some text -> text + | None -> "nobody" + ) + ) + Computation.Of ( + "a match on a captured value option", + (fun () -> + match alias with + | ValueSome text -> text + | ValueNone -> "" + ) + ) + Computation.Of ( + "a match on a captured union", + (fun () -> + match filter with + | ByName text -> text + | OlderThan age -> string age + ) + ) + Computation.Of ( + "a test of the type of a value", + (fun () -> + match box name with + | :? string as text -> text.Length + | _ -> -1 + ) + ) + Computation.Of ( + "a test of the type of a value of another type", + (fun () -> + match box limit with + | :? string as text -> text.Length + | _ -> -1 + ) + ) + Computation.Of ("a cast to an interface", (fun () -> (tags :> seq) |> Seq.length)) + + // Members of a nullable, which reflection has nothing to call on: a nullable is boxed as its value or as null + Computation.Of ("a nullable with a value that is asked whether it has one", (fun () -> optional.Limit.HasValue)) + Computation.Of ("a nullable without a value that is asked whether it has one", (fun () -> optional.Missing.HasValue)) + Computation.Of ("the value of a nullable", (fun () -> optional.Limit.Value)) + Computation.Of ("the value of a nullable or the default of its type", (fun () -> optional.Limit.GetValueOrDefault ())) + Computation.Of ( + "the default of its type for a nullable without a value", + (fun () -> optional.Missing.GetValueOrDefault ()) + ) + Computation.Of ("the value of a nullable or a default", (fun () -> optional.Limit.GetValueOrDefault 5)) + Computation.Of ("a default for a nullable without a value", (fun () -> optional.Missing.GetValueOrDefault 5)) + Computation.Of ("a nullable with a value as text", (fun () -> optional.Limit.ToString ())) + Computation.Of ("a nullable without a value as text", (fun () -> optional.Missing.ToString ())) + Computation.Of ("a nullable that is compared with a value", (fun () -> optional.Limit.Equals 30)) + Computation.Of ("a nullable without a value that is compared with null", (fun () -> optional.Missing.Equals null)) + Computation.Of ("the hash code of a nullable", (fun () -> optional.Limit.GetHashCode ())) + Computation.Of ("the hash code of a nullable without a value", (fun () -> optional.Missing.GetHashCode ())) + Computation.Of ("a nullable that is made of a value", (fun () -> Nullable limit)) + Computation.Of ("a nullable that a function takes", (fun () -> Option.ofNullable optional.Missing)) + + // Captured functions + Computation.Of ("a captured function that is applied", (fun () -> addOne limit)) + Computation.Of ("a captured function of two arguments", (fun () -> add limit 1)) + Computation.Of ("a captured function that is applied to what another gives", (fun () -> addOne (add limit 1))) + } + |> ImmutableArray.CreateRange + + static let failures = + let name = "Bob" + let limit = 30 + let noNick : string option = None + let refuse : unit -> int = fun () -> invalidOp "No value." + let optional = {| Missing = Nullable() |} + let missing : int -> int = Unchecked.defaultof int> + let noName : string = Unchecked.defaultof + + seq { + struct ("a text that is no number", Computation.PartOf <@ fun () -> Int32.Parse name @>, typeof) + struct ("a division by zero", Computation.PartOf <@ fun () -> limit / (limit - 30) @>, typeof) + struct ("a checked conversion that does not fit", + Computation.PartOf <@ fun () -> Checked.byte (limit * 10) @>, + typeof) + struct ("a checked negation that does not fit", + Computation.PartOf <@ fun () -> Checked.(~-) (Int32.MinValue + limit - 30) @>, + typeof) + struct ("a member of a value that is null", + Computation.PartOf <@ fun () -> noNick.Value.Length @>, + typeof) + struct ("a captured function that raises", + Computation.PartOf <@ fun () -> refuse () + 1 @>, + typeof) + struct ("the value of a nullable without a value", + Computation.PartOf <@ fun () -> optional.Missing.Value @>, + typeof) + struct ("a function that is null and is applied", + Computation.PartOf <@ fun () -> missing limit @>, + typeof) + // Compiled code computes the arguments before it finds that there is nothing to call. + struct ("a method of a value that is null with an argument that raises", + Computation.PartOf <@ fun () -> noName.Substring (limit / (limit - 30)) @>, + typeof) + struct ("an indexed property of a value that is null with an argument that raises", + Computation.PartOf <@ fun () -> noName.Chars (limit / (limit - 30)) @>, + typeof) + struct ("a function that is null and is applied to an argument that raises", + Computation.PartOf <@ fun () -> missing (limit / (limit - 30)) @>, + typeof) + } + |> ImmutableArray.CreateRange + + /// + /// Every computation as a row of a data-driven test. The name of a row replaces the name of the test method in the + /// results, so it says what is asserted. + /// + static member Computations : IEnumerable> = + computations + |> Seq.map (fun computation -> + TestDataRow( + computation, + DisplayName = $"%s{computation.Name} must have the value that the compiled code gives" + ) + ) + + /// + /// Every code that raises an exception, with the type of the exception, as a row of a data-driven test. + /// + static member Failures : IEnumerable> = + failures + |> Seq.map (fun (struct (name, part, cause)) -> + TestDataRow( + struct (part, cause), + DisplayName = $"%s{name} must be reported with the exception as the cause" + ) + ) + + [] + member _.``A part that reads no variable must have the value that the compiled code gives`` (computation : Computation) = + match Evaluator.tryEvaluate computation.Part with + | Ok value -> computation.IsExpected value + | Error error -> Assert.Fail $"The part should have a value, but: %s{error.Message}\n%s{error.Fragment}" + + [] + member _.``Code that raises an exception must be reported with the exception as the cause`` (part : Expr, cause : Type) = + let error = + Assert.WantError (Evaluator.tryEvaluate part, "The code raises an exception, so the part has no value.") + + Assert.AreEqual( + TranslationErrorCode.ClientEvaluationFailed, + error.Code, + "An exception of the caller's code is a failed evaluation." + ) + + let raised = Assert.WantValueSome (error.Cause, "The error should carry the exception.") + Assert.IsInstanceOfType (raised, cause, "The cause should be the exception of the code, not a wrapper of reflection.") + Assert.Contains (cause.Name, error.Message, StringComparison.Ordinal, "The message should name the exception.") + Assert.IsNotEmpty (error.Hints, "The error should say what to write instead.") + Assert.IsValueSome (error.Location, "The part was written in this file, so it has its place.") + + [] + member _.``Every operator that FSharp.Core does not let reflection call must have a function that stands in for it`` () = + // FSharp.Core marks the methods that raise when reflection calls them. Rethrow and Reraise are among them, and + // have nothing to compute. + let isMarked (method : MethodInfo) = + method.GetCustomAttributesData () + |> Seq.exists (fun attribute -> attribute.AttributeType.Name = "NoDynamicInvocationAttribute") + + let withoutStandIn = + seq { + typeof.Assembly.GetType("Microsoft.FSharp.Core.Operators", true) + typeof.Assembly.GetType("Microsoft.FSharp.Core.Operators+Checked", true) + } + |> Seq.collect (fun operators -> + match operators with + | null -> Seq.empty + | operators -> + operators.GetMethods (BindingFlags.Public ||| BindingFlags.Static) + |> Seq.ofArray + ) + |> Seq.filter (fun method -> + isMarked method + && not (method.Name.EndsWith ("$W", StringComparison.Ordinal)) + && method.Name <> "Rethrow" + && method.Name <> "Reraise" + && not (Evaluator.dynamicOperators.ContainsKey method.MetadataToken) + ) + |> Seq.map (fun method -> $"%s{(nonNull method.DeclaringType).Name}.%s{method.Name}") + |> Seq.toArray + + Assert.IsEmpty ( + withoutStandIn, + "A version of FSharp.Core that keeps another operator from reflection needs another row in the evaluator." + ) + + [] + member _.``Every part that the evaluator computes must be told computable`` () = + let refused = + seq { + for computation in computations do + if not (Evaluator.canEvaluate (Evaluator.Refused ()) computation.Part) then + computation.Name + + for struct (name, part, _) in failures do + if not (Evaluator.canEvaluate (Evaluator.Refused ()) part) then + name + } + |> Seq.toArray + + Assert.IsEmpty ( + refused, + "A part that has a value, or that raises while it is computed, is made only of what the evaluator computes." + ) + + [] + member _.``A part that holds a function, a variable or a quotation must be told not computable, and none of it must run`` () = + let meter = Meter () + let variable = Expr.Var (Var ("number", typeof)) + + // In each of the first two the part before the one that cannot be computed can be: asking must not run it. + let withVariable = <@@ [| meter.Read 1; %%variable |] @@> + let withFunction = <@@ List.map (fun number -> number + 1) [ meter.Read 1 ] @@> + let quotation = Expr.QuoteTyped <@@ 1 @@> + + let refused = Evaluator.Refused () + + Assert.IsFalse (Evaluator.canEvaluate refused withVariable, "A variable has a value only inside the query.") + Assert.IsFalse (Evaluator.canEvaluate refused withFunction, "A function cannot be computed without compiling it.") + Assert.IsFalse (Evaluator.canEvaluate refused quotation, "A quotation inside the quotation is not computed.") + Assert.AreEqual(0, meter.Readings, "Asking whether a part can be computed should run no code of it.") + + Assert.IsFalse (Evaluator.canEvaluate refused withVariable, "A part that was refused stays refused.") + Assert.IsTrue (refused.Holds variable, "The variable is the reason, so it is remembered with the array around it.") + + match withVariable with + | NewArray (_, [ first; _ ]) -> + Assert.IsTrue (Evaluator.canEvaluate refused first, "The item before the variable can be computed on its own.") + | other -> Assert.Fail $"The quotation should be an array of two items: %A{other}" + + [] + member _.``A value that is bound once must be computed once for all its places in a part`` () = + let meter = Meter () + + let part = + Computation.PartOf + <@ + fun () -> + let made = meter.Read (obj ()) + obj.ReferenceEquals (made, made) + @> + + Assert.AreEqual( + true, + Assert.WantOk (Evaluator.tryEvaluate part, "A comparison of values that read no variable has a value."), + "Both places hold the node that was bound, so both should get the one object it makes, as in compiled code." + ) + + Assert.AreEqual(1, meter.Readings, "The code of the bound value should run once.") + + [] + member _.``A node that was computed must not be computed again for a caller that keeps what was computed`` () = + let meter = Meter () + + // Both parts hold the very same node: a splice puts the node it is given into the quotation. + let reading = <@ meter.Read 18 @> + let first = NormalizerAssert.WantNormal <@@ %reading + 1 @@> + let second = NormalizerAssert.WantNormal <@@ %reading + 2 @@> + let computed = Evaluator.Computed () + + Assert.AreEqual( + 19, + Assert.WantOk (Evaluator.tryEvaluateOnce computed first, "A sum of values that read no variable has a value."), + "The first part should be computed with the value of the node." + ) + + Assert.AreEqual( + 20, + Assert.WantOk (Evaluator.tryEvaluateOnce computed second, "A sum of values that read no variable has a value."), + "The second part should be computed with the value that the node had for the first one." + ) + + Assert.AreEqual(1, meter.Readings, "The code of the node should run once for both parts.") + + Assert.WantOk (Evaluator.tryEvaluate second, "A sum of values that read no variable has a value.") + |> ignore + + Assert.AreEqual(2, meter.Readings, "A caller that keeps nothing has the part computed anew.") + + [] + member _.``An array must be built with its items in their order`` () = + let limit = 30 + let part = Computation.PartOf <@ fun () -> [| limit; 1; limit + 1 |] @> + let value = + Assert.WantOk (Evaluator.tryEvaluate part, "An array of values that read no variable has a value.") + + match value with + | :? (int array) as items -> + CollectionAssert.AreEqual ( + [| 30; 1; 31 |], + items, + "The array should hold the three values in the order they are written." + ) + | other -> Assert.Fail $"The value should be an array of integers, but is %A{other}." + + [] + member _.``The default value of a struct must be its zeroed value when the struct has a constructor without parameters`` () = + // F# declares no struct with a constructor without parameters, as C# can, so the test makes one: its + // constructor sets the field to 7. + let declared = + AssemblyBuilder + .DefineDynamicAssembly(AssemblyName "EvaluatorTests.Dynamic", AssemblyBuilderAccess.Run) + .DefineDynamicModule("Structs") + .DefineType( + "Seven", + TypeAttributes.Public + ||| TypeAttributes.Sealed + ||| TypeAttributes.SequentialLayout, + typeof + ) + + let field = declared.DefineField ("Value", typeof, FieldAttributes.Public) + + let code = + declared.DefineConstructor(MethodAttributes.Public, CallingConventions.Standard, Type.EmptyTypes).GetILGenerator() + + code.Emit OpCodes.Ldarg_0 + code.Emit (OpCodes.Ldc_I4, 7) + code.Emit (OpCodes.Stfld, field) + code.Emit OpCodes.Ret + + let seven = declared.CreateType () + let valueOf (instance : objnull) = (nonNull (seven.GetField "Value")).GetValue instance + + Assert.AreEqual( + box 7, + valueOf (Activator.CreateInstance seven), + "The constructor of the struct sets the field, so a value that it made is told from the default value." + ) + + match Evaluator.tryEvaluate (Expr.DefaultValue seven) with + | Ok value -> + Assert.AreEqual( + box 0, + valueOf value, + "The default value is the zeroed value: no constructor runs for it, as none runs in compiled code." + ) + | Error error -> Assert.Fail $"The default value should be computed, but: %s{error.Message}" + + [] + member _.``A coercion must give the value only when the value is of the target type`` () = + // The compiler writes a coercion only where the cast cannot fail, so these are built through the API. + let coerced (value : Expr) (targetType : Type) = Evaluator.tryEvaluate (Expr.Coerce (value, targetType)) + + let causeOf (result : Result) = + let error = Assert.WantError (result, "A cast that fails in compiled code has no value.") + + Assert.AreEqual( + TranslationErrorCode.ClientEvaluationFailed, + error.Code, + "A failed cast is an exception of the code that is run." + ) + + Assert.WantValueSome (error.Cause, "The error should carry the exception.") + + Assert.AreEqual( + 5, + Assert.WantOk (coerced (Expr.Value 5) typeof>, "A number is a value of the nullable of its type."), + "The value should be the number." + ) + + Assert.IsNull ( + Assert.WantOk (coerced (Expr.Value (null, typeof)) typeof, "Null is a value of every reference type."), + "The value should stay null." + ) + + Assert.IsInstanceOfType ( + causeOf (coerced (Expr.Value (box "text", typeof)) typeof), + typeof, + "A text is no number, whatever type the coercion names." + ) + + Assert.IsInstanceOfType ( + causeOf (coerced (Expr.Value 5) typeof), + typeof, + "A cast converts nothing: a boxed integer is no byte." + ) + + Assert.IsInstanceOfType ( + causeOf (coerced (Expr.Value (null, typeof)) typeof), + typeof, + "Null is no value of a value type that is not a nullable." + ) + + [] + member _.``A function that is written in the quotation must be reported as having no value`` () = + let error = + Assert.WantError ( + Evaluator.tryEvaluate <@@ fun (number : int) -> number + 1 @@>, + "A function cannot be computed without compiling it." + ) + + Assert.AreEqual(TranslationErrorCode.Unsupported, error.Code, "Nothing was run, so nothing failed.") + Assert.IsValueNone (error.Cause, "No exception is the reason.") + + [] + member _.``A variable must be reported as having no value`` () = + let error = + Assert.WantError ( + Evaluator.tryEvaluate (Expr.Var (Var ("number", typeof))), + "A variable has a value only inside the query." + ) + + Assert.AreEqual(TranslationErrorCode.Unsupported, error.Code, "Nothing was run, so nothing failed.") diff --git a/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj b/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj new file mode 100644 index 00000000..9ba36396 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj @@ -0,0 +1,49 @@ + + + + + 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..6f93f0a0 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/Model.fs @@ -0,0 +1,324 @@ +// 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 + +/// A function as a class that code declares; the class of every compiled function is made of the same type. +type TagTest (wanted : string) = + inherit FSharpFunc () + + /// + override _.Invoke (tag : string) : bool = tag = wanted + +/// A union with a case that is represented by null, as the None of an option is. +[] +type Rank = + /// The case that is null. + | Unranked + /// A case with a value. + | Ranked of int + +/// A pass for values that counts them: a test tells by it how often a part of a quotation was computed. +type Meter () = + + let mutable readings = 0 + + /// How many values have passed. + member _.Readings = readings + + /// + /// , counted. + /// + member _.Read (value : 'Value) : 'Value = + readings <- readings + 1 + value + +/// +/// Members added to outside its definition: the compiler +/// makes them static methods that take the person first. +/// +[] +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/ParameterizerShapeTests.fs b/tests/Cosmos.Quotations.Tests/ParameterizerShapeTests.fs new file mode 100644 index 00000000..06177e7b --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/ParameterizerShapeTests.fs @@ -0,0 +1,298 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations +open FSharp.Quotations.Patterns + +open FSharp.Azure.Cosmos +open FSharp.Azure.Cosmos.Quotations + +/// The values that the functions of the tests capture. A test writes its functions over two sets of them. +type CapturedValues = { + Limit : int + Name : string + Filter : string option + Flag : bool + Nick : string option + Tags : string list + Range : AgeRange + Comparison : StringComparison +} + +/// +/// A function of a person as a quotation, with the check that another quotation computes what its compiled code does. +/// +type PersonFunction = { + /// What the function is made of; the name of a test result starts with it. + Name : string + /// The quotation of the function as it is written. + Quotation : Expr + /// Fails unless the function that a quotation holds computes what the compiled code of this function does. + ComputesTheSame : Expr -> unit +} with + + /// + /// The function . The compiler passes the code together with its quotation. + /// + static member Of<'Result when 'Result : equality> + (name : string, [] code : Expr 'Result>) + : PersonFunction + = + let code = Quoted.Split code + + { + Name = name + Quotation = code.Quotation + ComputesTheSame = NormalizerAssert.ComputesTheSame code.Compiled Persons.all + } + +/// The functions that the laws of the parameterizer are checked on. +[] +module PersonFunctions = + + /// + /// Functions of a person written over , every one of a shape of its own: no two of + /// them may give one query text. Two calls give the same functions in the same order, with other values. + /// + let over (captured : CapturedValues) : ImmutableArray = + // Locals, because a local arrives in a quotation as a value with the name of its variable. + let limit = captured.Limit + let name = captured.Name + let filter = captured.Filter + let flag = captured.Flag + let nick = captured.Nick + let tags = captured.Tags + let range = captured.Range + let comparison = captured.Comparison + + seq { + // Literals + PersonFunction.Of ("a literal", (fun p -> p.Age > 18)) + PersonFunction.Of ("another literal", (fun p -> p.Age > 21)) + PersonFunction.Of ("a literal of another type", (fun p -> int64 p.Age > 18L)) + PersonFunction.Of ("a zero", (fun p -> float p.Age > 0.0)) + PersonFunction.Of ("a negative zero", (fun p -> float p.Age > -0.0)) + PersonFunction.Of ("a string", (fun p -> p.Name = "Bob")) + PersonFunction.Of ("an empty string", (fun p -> p.Name = "")) + PersonFunction.Of ("null", (fun p -> box p.Name = null)) + PersonFunction.Of ("a character", (fun p -> p.Name.Contains 'o')) + PersonFunction.Of ("a value of an enumeration", (fun p -> p.Name.StartsWith ("b", StringComparison.Ordinal))) + PersonFunction.Of ( + "another value of the enumeration", + (fun p -> p.Name.StartsWith ("b", StringComparison.OrdinalIgnoreCase)) + ) + + // Captured values + PersonFunction.Of ("a captured value", (fun p -> p.Age > limit)) + PersonFunction.Of ("a captured value on the other side", (fun p -> limit < p.Age)) + PersonFunction.Of ("a captured value that is used twice", (fun p -> p.Age > limit || fst p.Scores > limit)) + PersonFunction.Of ("two captured values", (fun p -> p.Name = name || fst p.Scores > limit)) + PersonFunction.Of ("a captured value of an enumeration", (fun p -> p.Name.StartsWith (name, comparison))) + PersonFunction.Of ("a captured option", (fun p -> p.Nick = nick)) + PersonFunction.Of ("a captured list", (fun p -> tags |> List.contains p.Name)) + PersonFunction.Of ("a captured record", (fun p -> { Low = p.Age; High = fst p.Scores } = range)) + + // Parts that are computed + PersonFunction.Of ("a property of a captured value", (fun p -> p.Age >= range.Low)) + PersonFunction.Of ("a call on a captured value", (fun p -> p.Name = name.ToUpperInvariant ())) + PersonFunction.Of ("arithmetic on a captured value", (fun p -> p.Age <= limit + 1)) + PersonFunction.Of ("a module-level value", (fun p -> p.Age < Conditions.retirementAge)) + PersonFunction.Of ("a static field", (fun p -> p.Name <> String.Empty)) + PersonFunction.Of ( + "an object that a constructor makes", + (fun p -> DateTime (2000 + p.Age, 1, 1) > DateTime (2000 + limit, 1, 1)) + ) + + // Values that the quotation builds + PersonFunction.Of ("an option with a captured value", (fun p -> p.Nick = Some name)) + PersonFunction.Of ("an option with a literal", (fun p -> p.Nick = Some "bobby")) + PersonFunction.Of ("an option without a value", (fun p -> p.Nick = None)) + PersonFunction.Of ("a list that is written item by item", (fun p -> [ name; "Dee" ] |> List.contains p.Name)) + PersonFunction.Of ("an array", (fun p -> [| name; "Dee" |] |> Array.contains p.Name)) + PersonFunction.Of ("a longer array", (fun p -> [| name; "Dee"; "Cy" |] |> Array.contains p.Name)) + PersonFunction.Of ("a tuple", (fun p -> p.Scores = (limit, 1))) + PersonFunction.Of ("a struct tuple", (fun p -> struct (fst p.Scores, snd p.Scores) = struct (limit, 1))) + PersonFunction.Of ("a record", (fun p -> { Low = p.Age; High = limit } = { Low = 30; High = limit })) + PersonFunction.Of ("an anonymous record", (fun p -> {| Low = p.Age |} = {| Low = limit |})) + PersonFunction.Of ("a default value", (fun p -> DateTime (2000 + p.Age, 1, 1) > DateTime ())) + + // Choices + PersonFunction.Of ("a choice by a captured value", (fun p -> flag || p.Active)) + PersonFunction.Of ("a choice that guards a computed part", (fun p -> filter.IsNone || p.Name = filter.Value.Trim ())) + PersonFunction.Of ( + "a choice with a computed part in its other branch", + (fun p -> if flag then p.Age > limit else p.Name = filter.Value) + ) + PersonFunction.Of ("a choice by the document", (fun p -> if p.Active then p.Age > limit + 1 else p.Age < limit + 2)) + + // Other operations on the document + PersonFunction.Of ("an item of a tuple", (fun p -> fst p.Scores > limit)) + PersonFunction.Of ("another item of a tuple", (fun p -> snd p.Scores > limit)) + PersonFunction.Of ( + "a test for a union case", + (fun p -> + match p.Nick with + | Some _ -> p.Active + | None -> p.Age > limit + ) + ) + PersonFunction.Of ("a test for a type", (fun p -> box p.Age :? int)) + PersonFunction.Of ("a value seen as a value of another type", (fun p -> (p.Name :> obj) = (name :> obj))) + PersonFunction.Of ("an inner function", (fun p -> p.Tags |> List.exists (fun tag -> tag = name))) + PersonFunction.Of ( + "an inner function that reads the document", + (fun p -> p.Tags |> List.exists (fun tag -> tag = p.Name)) + ) + } + |> ImmutableArray.CreateRange + + /// The functions over values with which every choice takes its first branch. + let first = + over { + Limit = 18 + Name = "bob" + Filter = None + Flag = true + Nick = None + Tags = [] + Range = { Low = 10; High = 9 } + Comparison = StringComparison.Ordinal + } + + /// The same functions over other values, with which every choice takes its other branch. + let second = + over { + Limit = 30 + Name = "Bob" + Filter = Some " Bob " + Flag = false + Nick = Some "bobby" + Tags = [ "Bob"; "Dee" ] + Range = { Low = 30; High = 10 } + Comparison = StringComparison.OrdinalIgnoreCase + } + +/// +/// The laws of : the key of a function does not depend on +/// the values the function captured, two functions that are not alike have different keys, the key is the same whether +/// or not the template is asked for, and the template with its values computes what the function computes. +/// +[] +type ParameterizerShapeTests () = + + /// + /// Every function with both sets of values, as a row of a data-driven test. The name of a row replaces the name of + /// the test method in the results, so it says what the function is made of and what the + /// method asserts. + /// + static member private Rows (law : string) : IEnumerable> = seq { + for written in PersonFunctions.first do + TestDataRow(written, DisplayName = $"%s{written.Name} %s{law}, with the first values") + + for written in PersonFunctions.second do + TestDataRow(written, DisplayName = $"%s{written.Name} %s{law}, with the second values") + } + + /// The rows of the test that compares the keys of one function with two sets of values. + static member SameKeyRows : IEnumerable> = + Seq.zip PersonFunctions.first PersonFunctions.second + |> Seq.map (fun (struct (first, second)) -> + TestDataRow( + struct (first, second), + DisplayName = $"%s{first.Name} must have one key whatever values are captured" + ) + ) + + /// The rows of the test that compares what is known without the template with what the template holds. + static member SameShapeRows = ParameterizerShapeTests.Rows "must have the key and the values of its template" + + /// The rows of the test that looks at what the template holds at the places of the values. + static member VariableRows = + ParameterizerShapeTests.Rows "must have a template with a variable for every slot and no captured value" + + /// The rows of the test that compares the template with the compiled code. + static member SameMeaningRows = + ParameterizerShapeTests.Rows "must have a template that computes what the compiled code computes" + + [] + member _.``A function must have one key whatever values are captured`` (first : PersonFunction, second : PersonFunction) = + let firstKey = (ParameterizerAssert.WantShape first.Quotation).Key + let secondKey = (ParameterizerAssert.WantShape second.Quotation).Key + + Assert.AreEqual(firstKey, secondKey, "The values a function captured should not be in its key.") + + Assert.AreEqual( + firstKey.GetHashCode (), + secondKey.GetHashCode (), + "Equal keys should have one hash code, or a dictionary does not find the second one." + ) + + [] + member _.``Two functions that are not alike must have different keys`` () = + let keys = + PersonFunctions.first + |> Seq.map (fun written -> struct (written.Name, (ParameterizerAssert.WantShape written.Quotation).Key)) + |> Seq.toArray + + let alike = + seq { + for index in 0 .. keys.Length - 1 do + for other in index + 1 .. keys.Length - 1 do + let struct (name, key) = keys[index] + let struct (otherName, otherKey) = keys[other] + + if key = otherKey then + $"%s{name} / %s{otherName}" + } + |> Seq.toArray + + Assert.IsEmpty (alike, "Functions with one key get one query text, so every pair here would share a wrong one.") + + [] + member _.``A function must have the key and the values of its template`` (written : PersonFunction) = + let shape = ParameterizerAssert.WantShape written.Quotation + let template = ParameterizerAssert.WantTemplate written.Quotation + + Assert.AreEqual( + template.Key, + shape.Key, + "The key that finds a translation should be the key the translation was made under." + ) + + CollectionAssert.AreEqual ( + template.Values |> Seq.toArray, + shape.Values |> Seq.toArray, + "The values should be the same, slot by slot." + ) + + Assert.HasCount (template.Slots.Length, shape.Values, "Every slot should have its place among the values.") + + [] + member _.``A function must have a template with a variable for every slot and no captured value`` (written : PersonFunction) = + let template = ParameterizerAssert.WantTemplate written.Quotation + + let captured = + template.Body + |> Quotation.filter (fun part -> + match part with + | ValueWithName _ -> true + | _ -> false + ) + + Assert.IsEmpty (captured, "A captured value is a parameter, so the template should hold a variable at its place.") + + CollectionAssert.AreEquivalent ( + template.Slots |> Seq.map _.Variable |> Seq.toArray, + template.Body.GetFreeVars () |> Seq.toArray, + "The variables that the template leaves unbound should be the variables of its slots, every one of them." + ) + + [] + member _.``A function must have a template that computes what the compiled code computes`` (written : PersonFunction) = + written.Quotation + |> ParameterizerAssert.WantTemplate + |> Templates.withValues + |> written.ComputesTheSame diff --git a/tests/Cosmos.Quotations.Tests/ParameterizerTests.fs b/tests/Cosmos.Quotations.Tests/ParameterizerTests.fs new file mode 100644 index 00000000..2ef37611 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/ParameterizerTests.fs @@ -0,0 +1,1112 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Linq +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations +open FSharp.Quotations.Patterns + +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// Values declared as literals, which the compiler writes into a quotation in place of their names. +module Literals = + + /// The first letter of a name. + [] + let Initial = "B" + + /// A rate, as a decimal. + [] + let Rate = 2.5m + +/// +/// What makes of the values in a quotation: which of them +/// are slots, under which names and with which values, which are parts of the key, and what is an error. +/// +[] +type ParameterizerTests () = + + /// The value of a slot, which a test expects to have been computed. + static let valueOf (index : int) (values : Collections.Immutable.ImmutableArray) : objnull = + Assert.WantValueSome (values[index], $"The slot %d{index} is in a branch that is taken, so it should have a value.") + + /// The module of the functions that say how a value gets into the query. + static let queryModule = + match <@ Query.constant 0 @> with + | Call (None, method, _) -> method.DeclaringType + | other -> invalidOp $"The quotation is not a call of a function: %A{other}" + + /// Whether a quotation calls a function of the Query module. + static let callsQuery (expr : Expr) : bool = + expr + |> Quotation.exists (fun part -> + match part with + | Call (None, method, _) -> Type.(=) (method.DeclaringType, queryModule) + | _ -> false + ) + + /// A quotation with a value of its own under the name that every quotation made here gives its value. + static let olderThan (age : int) : Expr bool> = <@ fun person -> person.Age > age @> + + /// A quotation that captures a name. + static let named (name : string) : Expr bool> = <@ fun person -> person.Name = name @> + + /// Another quotation that captures a variable of the same name. + static let nicknamed (name : string) : Expr bool> = <@ fun person -> person.Nick = Some name @> + + /// Quotations that build a value from a captured name, each with the types of the slots it has to give. + static member BuiltValueRows : IEnumerable> = + let name = "Bob" + let limit = 30 + + seq { + struct ("An option", <@@ fun (p : Person) -> p.Nick = Some name @@>, [| typeof |]) + struct ("A list", <@@ fun (p : Person) -> [ name; "Dee" ] |> List.contains p.Name @@>, [| typeof |]) + struct ("An array", <@@ fun (p : Person) -> [| name; "Dee" |] |> Array.contains p.Name @@>, [| typeof |]) + struct ("A tuple", <@@ fun (p : Person) -> p.Scores = (limit, 1) @@>, [| typeof |]) + struct ("A struct tuple", + <@@ fun (p : Person) -> struct (p.Name, p.Age) = struct (name, limit) @@>, + [| typeof; typeof |]) + struct ("A record", + <@@ fun (p : Person) -> { Low = p.Age; High = 1 } = { Low = limit; High = 1 } @@>, + [| typeof |]) + struct ("An anonymous record", + <@@ fun (p : Person) -> {| Name = p.Name |} = {| Name = name |} @@>, + [| typeof |]) + } + |> Seq.map (fun (struct (built, quotation, slots)) -> + TestDataRow( + struct (quotation, slots), + DisplayName = $"%s{built} that the quotation builds must stay what it is, with its parts as slots" + ) + ) + + /// Quotations that pass a function value where the query would need to read the function. + static member FunctionValueRows : IEnumerable> = + let isVip = fun (tag : string) -> tag = "vip" + let isNew = Func(fun tag -> tag = "new") + let hiddenFunction : obj = isVip + let hiddenDelegate : obj = isNew + let ownFunction = TagTest "vip" + + seq { + struct ("A captured function that is passed into the query", <@@ fun (p : Person) -> p.Tags |> List.exists isVip @@>) + struct ("A captured delegate that is passed into the query", + <@@ fun (p : Person) -> Enumerable.Any (p.Tags, isNew) @@>) + struct ("A function that a call returns into the query", + <@@ fun (p : Person) -> [ p ] |> List.exists (Conditions.olderThan 18) @@>) + struct ("A module-level function value that is passed into the query", + <@@ fun (p : Person) -> [ p ] |> List.exists Conditions.isSenior @@>) + + // The type of the part does not say that the value is a function + struct ("A captured function that is passed as an object", + <@@ fun (p : Person) -> Object.Equals (p.Tags, hiddenFunction) @@>) + struct ("A captured delegate that is passed as an object", + <@@ fun (p : Person) -> Object.Equals (p.Tags, hiddenDelegate) @@>) + struct ("A function that a call returns as an object", + <@@ fun (p : Person) -> Object.Equals (p.Tags, box (Conditions.olderThan 18)) @@>) + + // The type of the part is a class made of the type of functions + struct ("A captured function of a class that code declares", + <@@ fun (p : Person) -> Object.Equals (p.Tags, ownFunction) @@>) + + // A function is no constant of a query either + struct ("A function that Query.constant is given", + <@@ fun (p : Person) -> p.Tags |> List.exists (Query.constant isVip) @@>) + struct ("A function that Query.constant is given as an object", + <@@ fun (p : Person) -> Object.Equals (p.Tags, Query.constant hiddenFunction) @@>) + + // A function that is not there is no value of a query either. Only code builds these two: the compiler + // writes no null of a function type. + struct ("The null of a function type that code builds into the query", + <@@ + fun (p : Person) -> + p.Tags + |> List.exists %%(Expr.Value (null, typeof bool>)) + @@>) + struct ("The default value of a function type that code builds into the query", + <@@ + fun (p : Person) -> + p.Tags + |> List.exists %%(Expr.DefaultValue typeof bool>) + @@>) + } + |> Seq.map (fun (struct (passed, quotation)) -> + TestDataRow(quotation, DisplayName = $"%s{passed} must be reported") + ) + + /// Quotations that give Query.constant a value that a query cannot hold as a literal. + static member NotLiteralRows : IEnumerable> = + let range = { Low = 1; High = 2 } + let tags = [| "vip" |] + let rate = 2.5m + let day = DateTime (2026, 1, 1) + let address = Uri "http://localhost" + let count = Nullable 5 + let noCount = Nullable() + let nobody : string option = None + let unranked = Unranked + let notANumber = Double.NaN + let boundless = Double.NegativeInfinity + let smallNotANumber = Single.NaN + + seq { + struct ("A record", <@@ fun (p : Person) -> { Low = p.Age; High = 2 } = Query.constant range @@>) + struct ("An array", <@@ fun (p : Person) -> Query.constant tags |> Array.contains p.Name @@>) + struct ("A decimal", <@@ fun (p : Person) -> decimal p.Age > Query.constant rate @@>) + struct ("A date", <@@ fun (p : Person) -> DateTime (2000 + p.Age, 1, 1) > Query.constant day @@>) + struct ("An object", <@@ fun (p : Person) -> Object.Equals (p.Name, Query.constant address) @@>) + struct ("A nullable with a value", <@@ fun (p : Person) -> Nullable p.Age = Query.constant count @@>) + struct ("A nullable without a value", <@@ fun (p : Person) -> Nullable p.Age = Query.constant noCount @@>) + struct ("An option without a value", <@@ fun (p : Person) -> p.Nick = Query.constant nobody @@>) + struct ("A case of a union that is null", <@@ fun (p : Person) -> Object.Equals (p.Name, Query.constant unranked) @@>) + struct ("NaN", <@@ fun (p : Person) -> float p.Age > Query.constant notANumber @@>) + struct ("An infinity", <@@ fun (p : Person) -> float p.Age > Query.constant boundless @@>) + struct ("A NaN of a single", <@@ fun (p : Person) -> float32 p.Age > Query.constant smallNotANumber @@>) + } + |> Seq.map (fun (struct (given, quotation)) -> + TestDataRow(quotation, DisplayName = $"%s{given} that Query.constant is given must be reported") + ) + + // Slots + + [] + member _.``A captured value must be a slot that is named after its variable`` () = + let limit = 18 + let template = ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > limit @> + + let slot = Assert.ContainsSingle (template.Slots, "The quotation captures one value.") + Assert.AreEqual(ValueSome "limit", slot.Name, "The slot should have the name of the variable.") + Assert.AreEqual(typeof, slot.Variable.Type, "The variable of the slot should have the type of the value.") + Assert.AreEqual(18, valueOf 0 template.Values, "The value of the slot should be the captured value.") + + [] + member _.``A captured variable that is used twice must be a slot at each place`` () = + let limit = 18 + let name = "Bob" + + let ofValueType = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > limit || fst p.Scores > limit @> + let ofReferenceType = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Name = name || p.Nick = Some name @> + + CollectionAssert.AreEqual ( + [| ValueSome "limit"; ValueSome "limit" |], + ofValueType.Slots |> Seq.map _.Name |> Seq.toArray, + "The compiler writes each use as a node of its own, and nothing in the nodes says that they are one variable." + ) + + CollectionAssert.AreEqual ( + [| box 18; box 18 |], + [| valueOf 0 ofValueType.Values; valueOf 1 ofValueType.Values |], + "Each slot should hold the value of the variable." + ) + + Assert.HasCount (2, ofReferenceType.Slots, "Two nodes that hold one object are two slots like any two nodes.") + + [] + member _.``Two captured variables of one name must be two slots whatever they hold`` () = + // Each splice captured its own variable `age`. + let both (first : int) (second : int) = <@ fun (p : Person) -> (%olderThan first) p && (%olderThan second) p @> + + let different = ParameterizerAssert.WantTemplate (both 18 65) + let same = ParameterizerAssert.WantTemplate (both 18 18) + + CollectionAssert.AreEqual ( + [| ValueSome "age"; ValueSome "age" |], + different.Slots |> Seq.map _.Name |> Seq.toArray, + "Each slot should keep the name of its variable." + ) + + CollectionAssert.AreEqual ( + [| box 18; box 65 |], + [| valueOf 0 different.Values; valueOf 1 different.Values |], + "The slots should hold the two values in the order of their first use." + ) + + Assert.HasCount (2, same.Slots, "Two variables stay two parameters when they happen to hold one value.") + + Assert.AreEqual( + different.Key, + same.Key, + "The key should not say whether two values are equal this time, or one query would have two texts." + ) + + [] + member _.``Two captured variables of one name must be two slots when they hold one object`` () = + // Each splice captured its own variable `name`, and both variables hold the same string. + let text = "Bob" + let template = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> (%named text) p || (%nicknamed text) p @> + + CollectionAssert.AreEqual ( + [| ValueSome "name"; ValueSome "name" |], + template.Slots |> Seq.map _.Name |> Seq.toArray, + "What two variables hold does not make them one: the next time they can hold two objects." + ) + + [] + member _.``Two captured variables of one value must be two slots when their names differ`` () = + let low = 18 + let high = 18 + let template = ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age >= low && p.Age <= high @> + + CollectionAssert.AreEqual ( + [| ValueSome "low"; ValueSome "high" |], + template.Slots |> Seq.map _.Name |> Seq.toArray, + "Two variables are two parameters, also when they happen to hold one value." + ) + + [] + member _.``A captured value that is bound by let must be one slot for all its uses`` () = + let limit = 18 + + let template = + ParameterizerAssert.WantTemplate + <@ + fun (p : Person) -> + let age = limit + p.Age > age || fst p.Scores > age + @> + + let slot = + Assert.ContainsSingle ( + template.Slots, + "The normalizer writes the bound node at both places, and one node is one slot." + ) + + Assert.AreEqual(ValueSome "limit", slot.Name, "The slot should have the name of the captured variable.") + + [] + member _.``A quotation that is spliced into two places must be one slot for both`` () = + let limit = 18 + + // The quotation binds a value, so the normalizer rewrites it before the slots are told. + let age = + <@ + let years = limit + years + 1 + @> + + let template = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > %age || fst p.Scores > %age @> + + Assert.ContainsSingle ( + template.Slots, + "A splice puts one node at both places, the normalizer keeps it one node, and one node is one slot." + ) + |> ignore + + Assert.AreEqual(19, valueOf 0 template.Values, "The slot should hold the value that the spliced code computes.") + + [] + member _.``The name of a captured variable must be in the key`` () = + let keyOf (expr : Expr) = (ParameterizerAssert.WantShape expr).Key + let limit = 18 + let minimum = 18 + + Assert.AreNotEqual( + keyOf <@ fun (p : Person) -> p.Age > limit @>, + keyOf <@ fun (p : Person) -> p.Age > minimum @>, + "The parameter of a query is named after the variable, so another name is another query text." + ) + + [] + member _.``The type of a slot must be in the key`` () = + let keyOf (expr : Expr) = (ParameterizerAssert.WantShape expr).Key + + let ofAddress = + let value = Uri "http://localhost" + keyOf <@ fun (p : Person) -> Object.Equals (p.Name, value) @> + + let ofText = + let value = "5" + keyOf <@ fun (p : Person) -> Object.Equals (p.Name, value) @> + + Assert.AreNotEqual(ofAddress, ofText, "A value of another type is written into the query in another way.") + + [] + member _.``The index of a slot must be in the key`` () = + let limit = 18 + + // The same condition twice; the second one binds the value, so it is one slot at both places. + let ofTwoSlots = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > limit || fst p.Scores > limit @> + + let ofOneSlot = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let limit = limit + p.Age > limit || fst p.Scores > limit + @> + + Assert.HasCount (2, ofTwoSlots.Values, "Two uses of a captured variable are two slots.") + + Assert.ContainsSingle (ofOneSlot.Values, "A bound value is one slot at all its places.") + |> ignore + + Assert.AreNotEqual( + ofTwoSlots.Key, + ofOneSlot.Key, + "One parameter at two places and two parameters are different query texts, and they take a different number of values." + ) + + [] + member _.``A part that reads no variable must be one slot without a name`` () = + let limit = 18 + let template = ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > (limit + 1) * 2 @> + + let slot = + Assert.ContainsSingle (template.Slots, "The largest part that can be computed should be one slot.") + Assert.AreEqual(ValueNone, slot.Name, "A computed value has no variable to be named after.") + Assert.AreEqual(38, valueOf 0 template.Values, "The slot should hold what the part computes.") + + [] + member _.``A choice that reads nothing of the document must be one slot`` () = + let shapeOf (filter : string option) = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Name = (if filter.IsNone then "" else filter.Value.Trim ()) @> + + let without = shapeOf None + let withFilter = shapeOf (Some " Bob ") + + CollectionAssert.AreEqual ( + [| ValueSome (box "") |], + without.Values |> Seq.toArray, + "The choice is computed as a whole, as compiled code computes it: nothing is trimmed without a filter." + ) + + CollectionAssert.AreEqual ( + [| ValueSome (box "Bob") |], + withFilter.Values |> Seq.toArray, + "The choice is one value, so it is one slot, whichever branch gives the value." + ) + + Assert.AreEqual(without.Key, withFilter.Key, "The key should not say which branch gave the value.") + + [] + member _.``A module-level value must be a slot`` () = + let shape = ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > Conditions.retirementAge @> + + Assert.ContainsSingle (shape.Values, "The value is read before the query runs.") + |> ignore + + Assert.AreEqual(65, valueOf 0 shape.Values, "The slot should hold the value of the module.") + + [] + member _.``A value bound by let must be computed once for all its uses`` () = + let meter = Meter () + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let limit = meter.Read 18 + p.Age > limit || fst p.Scores > limit + @> + + Assert.ContainsSingle (shape.Values, "The normalizer writes the bound value at both places, and it is one value.") + |> ignore + + Assert.AreEqual(1, meter.Readings, "The code of the value should run once.") + + [] + member _.``Values bound by two lets must each be computed once for all their uses`` () = + let low = Meter () + let high = Meter () + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let least = low.Read 18 + let most = high.Read 65 + (p.Age > least && p.Age < most) + || (fst p.Scores > least && fst p.Scores < most) + @> + + Assert.HasCount ( + 2, + shape.Values, + "Each bound value should stay one node when the other one is written into the quotation." + ) + + Assert.AreEqual(1, low.Readings, "The code of the value that is bound first should run once.") + Assert.AreEqual(1, high.Readings, "The code of the value that is bound second should run once.") + + [] + member _.``A value bound by let must be computed once when two computed parts read it`` () = + let meter = Meter () + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let limit = meter.Read 18 + p.Age > limit + 1 || fst p.Scores > limit + 2 + @> + + CollectionAssert.AreEqual ( + [| ValueSome (box 19); ValueSome (box 20) |], + shape.Values |> Seq.toArray, + "Each sum is the largest part at its place that can be computed, so each is a slot of its own." + ) + + Assert.AreEqual(1, meter.Readings, "Both sums read the one value that was bound, whose code should run once.") + + [] + member _.``A value bound by let must be computed once when a later value reads it`` () = + let meter = Meter () + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let limit = meter.Read 18 + let twice = limit * 2 + (p.Age > limit && p.Age < twice) + || (fst p.Scores > limit && fst p.Scores < twice) + @> + + CollectionAssert.AreEqual ( + [| ValueSome (box 18); ValueSome (box 36) |], + shape.Values |> Seq.toArray, + "The value and what is made of it are one slot each, however often they are used." + ) + + Assert.AreEqual(1, meter.Readings, "The code of the first value should run once, also for the value made of it.") + + // Literals + + [] + member _.``A literal must be a part of the key and no slot`` () = + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + p.Age > 18 + && float p.Age > 0.5 + && p.Name <> "" + && p.Name.Contains 'o' + && p.Name.StartsWith ("B", StringComparison.Ordinal) + && box p.Nick <> null + && ignore p.Age = () + @> + + Assert.IsEmpty (shape.Values, "A literal is a part of the query text, whatever its type is.") + + [] + member _.``A decimal that is written must be a slot, also when it is declared as a literal`` () = + // The compiler writes a decimal as a call that makes it, never as a value. + let written = ParameterizerAssert.WantShape <@ fun (price : decimal) -> price > 18.5m @> + let declared = ParameterizerAssert.WantShape <@ fun (price : decimal) -> price > Literals.Rate @> + + CollectionAssert.AreEqual ( + [| ValueSome (box 18.5m) |], + written.Values |> Seq.toArray, + "A decimal should be a parameter, which keeps its digits." + ) + + CollectionAssert.AreEqual ( + [| ValueSome (box 2.5m) |], + declared.Values |> Seq.toArray, + "A decimal that is declared as a literal is written into the quotation the same way." + ) + + Assert.AreEqual(written.Key, declared.Key, "Two decimals are two values of one query text.") + + [] + member _.``A value declared as a literal must be the literal`` () = + let declared = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Name.StartsWith (Literals.Initial, StringComparison.Ordinal) @> + + let written = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Name.StartsWith ("B", StringComparison.Ordinal) @> + + Assert.IsEmpty (declared.Values, "The compiler writes the value into the quotation, so it is no slot.") + Assert.AreEqual(written.Key, declared.Key, "The declared literal and the written one are one quotation.") + + [] + member _.``A value that code put into a quotation must be a slot unless the compiler could have written it`` () = + let id = Guid.NewGuid () + let ofData = + ParameterizerAssert.WantTemplate <@ fun (documentId : Guid) -> documentId = %%(Expr.Value id) @> + let ofLiteral = ParameterizerAssert.WantTemplate <@ fun (age : int) -> age = %%(Expr.Value 5) @> + + let slot = Assert.ContainsSingle (ofData.Slots, "No literal is a Guid, so the value is data.") + Assert.AreEqual(ValueNone, slot.Name, "A value without a variable has no name.") + Assert.AreEqual(id, valueOf 0 ofData.Values, "The slot should hold the value.") + Assert.IsEmpty (ofLiteral.Slots, "A number cannot be told from a literal, so it is one.") + + [] + member _.``A number that is not finite must be a slot when code put it into a quotation, and a finite one a literal`` () = + // The text of a query has no NaN and no infinity, so a part of the key cannot be one. + let ofFinite = ParameterizerAssert.WantTemplate <@ fun (age : float) -> age = %%(Expr.Value 2.5) @> + Assert.IsEmpty (ofFinite.Slots, "A finite number is a literal, which the compiler could have written.") + + for value in + seq { + Double.NaN + Double.PositiveInfinity + Double.NegativeInfinity + } do + let template = ParameterizerAssert.WantTemplate <@ fun (age : float) -> age = %%(Expr.Value value) @> + let slot = + Assert.ContainsSingle (template.Slots, $"%f{value} cannot be written into the text of a query.") + Assert.AreEqual(typeof, slot.Variable.Type, "The slot should have the type of the node.") + Assert.AreEqual(value, valueOf 0 template.Values, "The slot should hold the value.") + + let single = + ParameterizerAssert.WantTemplate <@ fun (age : float32) -> age = %%(Expr.Value Single.NaN) @> + Assert.ContainsSingle (single.Slots, "The NaN of a single is data too.") + |> ignore + + let finiteSingle = + ParameterizerAssert.WantTemplate <@ fun (age : float32) -> age = %%(Expr.Value 2.5f) @> + Assert.IsEmpty (finiteSingle.Slots, "A finite single is a literal.") + + [] + member _.``A nullable that code put into a quotation must be a slot, with a value and without one`` () = + // A nullable with a value is boxed as the value, so only the type of the node says that it is a nullable. + let withValue = + ParameterizerAssert.WantTemplate <@ fun (age : Nullable) -> age = %%(Expr.Value (Nullable 5)) @> + let withoutValue = + ParameterizerAssert.WantTemplate <@ fun (age : Nullable) -> age = %%(Expr.Value (Nullable())) @> + + let slot = + Assert.ContainsSingle (withValue.Slots, "The compiler writes no nullable as a value, so it is data.") + Assert.AreEqual(typeof>, slot.Variable.Type, "The slot should have the type of the node.") + Assert.AreEqual(5, valueOf 0 withValue.Values, "The slot should hold the value.") + + Assert.ContainsSingle (withoutValue.Slots, "A nullable without a value is data as well, and no null literal.") + |> ignore + + Assert.IsNull (valueOf 0 withoutValue.Values, "The slot should hold no value.") + + [] + member _.``A case of a union that is null must be a slot when code put it into a quotation as a value`` () = + // The compiler writes a case of a union as a case, also the one that is represented by null. As a value such a + // null can only come from code, and how it is written into a query is a matter of the union. + let ofUnion = + ParameterizerAssert.WantTemplate <@ fun (rank : Rank) -> rank = %%(Expr.Value (null, typeof)) @> + + let ofOption = + ParameterizerAssert.WantTemplate + <@ fun (nick : string option) -> nick = %%(Expr.Value (null, typeof)) @> + + let ofText = + ParameterizerAssert.WantTemplate <@ fun (name : string | null) -> name = %%(Expr.Value (null, typeof)) @> + + let slot = + Assert.ContainsSingle (ofUnion.Slots, "The null of a union type is a case of the union, so it is data.") + Assert.AreEqual(typeof, slot.Variable.Type, "The slot should have the type of the union.") + Assert.IsNull (valueOf 0 ofUnion.Values, "The slot should hold the case, which is null.") + + Assert.ContainsSingle (ofOption.Slots, "An option is such a union, and its None is data as well.") + |> ignore + + Assert.IsEmpty (ofText.Slots, "The compiler writes the null of a text as a value, so that one is a literal.") + + [] + member _.``A function with a definition that is called twice must have the slots of each call`` () = + // The function binds a number, reads it and reads ten times the number: two values that a call computes. + let template = + ParameterizerAssert.WantTemplate + <@ + fun (p : Person) -> + Conditions.isWithinProcessors p + || not (Conditions.isWithinProcessors p) + @> + + Assert.HasCount ( + 4, + template.Slots, + "Each call computes its values for itself, so the second call should not have the slots of the first." + ) + + // Values that the quotation builds + + [] + member _.``A value that the quotation builds must stay what it is, with its parts as slots`` + (quotation : Expr, slots : Type array) + = + let template = ParameterizerAssert.WantTemplate quotation + + CollectionAssert.AreEqual ( + slots, + template.Slots |> Seq.map _.Variable.Type |> Seq.toArray, + "The captured parts should be the slots, and the value that is built of them no slot of its own." + ) + + // The functions of Query + + [] + member _.``Query.parameter must make a literal a slot`` () = + let template = ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > Query.parameter 18 @> + let other = ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > Query.parameter 21 @> + let literal = ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > 18 @> + + let slot = Assert.ContainsSingle (template.Slots, "The literal should be a parameter.") + Assert.AreEqual(ValueNone, slot.Name, "A literal has no variable to be named after.") + Assert.AreEqual(18, valueOf 0 template.Values, "The slot should hold the literal.") + Assert.AreEqual(template.Key, other.Key, "Another value of the parameter is the same query text.") + Assert.AreNotEqual(template.Key, literal.Key, "A parameter and a literal are different query texts.") + Assert.IsFalse (callsQuery template.Body, "The template should hold the variable of the slot, not the call.") + + [] + member _.``Query.parameter must leave a captured value the slot it is`` () = + let limit = 18 + let marked = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > Query.parameter limit || fst p.Scores > limit @> + let plain = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > limit || fst p.Scores > limit @> + + CollectionAssert.AreEqual ( + [| ValueSome "limit"; ValueSome "limit" |], + marked.Slots |> Seq.map _.Name |> Seq.toArray, + "The marked use should be a slot with the name of the variable, like the plain use." + ) + + Assert.AreEqual(plain.Key, marked.Key, "Saying what a captured value already is changes nothing.") + + [] + member _.``Query.parameter must compute its argument`` () = + let name = "bob" + let shape = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Name = Query.parameter (name.ToUpperInvariant ()) @> + + Assert.ContainsSingle (shape.Values, "The argument reads nothing of the document, so it is one slot.") + |> ignore + + Assert.AreEqual("BOB", valueOf 0 shape.Values, "The slot should hold what the argument computes.") + + [] + member _.``Query.constant must make a captured value a part of the key`` () = + let templateOf (limit : int) = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> p.Age > Query.constant limit @> + let template = templateOf 18 + let literal = NormalizerAssert.WantNormal <@ fun (p : Person) -> p.Age > 18 @> + + Assert.IsEmpty (template.Slots, "A constant is no parameter.") + + Assert.AreEqual( + (ParameterizerAssert.WantShape literal).Key, + template.Key, + "The constant should be in the key as the literal with its value is." + ) + + Assert.AreNotEqual(template.Key, (templateOf 21).Key, "Another value of a constant is another query text.") + + NormalizerAssert.AreEquivalent + literal + template.Body + "The template should hold the value where the call was, as if the literal had been written." + + [] + member _.``Query.constant must compute its argument`` () = + let limit = 18 + let computed = + ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > Query.constant (limit + 1) @> + let literal = ParameterizerAssert.WantShape <@ fun (p : Person) -> p.Age > 19 @> + + Assert.IsEmpty (computed.Values, "A constant is no parameter.") + Assert.AreEqual(literal.Key, computed.Key, "The key should hold what the argument computes.") + + // Choices + + [] + member _.``A branch that is not taken must not be computed`` () = + let shapeOf (filter : string option) = + ParameterizerAssert.WantShape <@ fun (p : Person) -> filter.IsNone || p.Name = filter.Value.Trim () @> + + let without = shapeOf None + let withFilter = shapeOf (Some " Bob ") + + CollectionAssert.AreEqual ( + [| ValueSome (box true); ValueNone |], + without.Values |> Seq.toArray, + "Without a filter nothing is trimmed: the code would raise, as it would in the compiled function." + ) + + CollectionAssert.AreEqual ( + [| ValueSome (box false); ValueSome (box "Bob") |], + withFilter.Values |> Seq.toArray, + "With a filter the branch is taken and its part is computed." + ) + + Assert.AreEqual(without.Key, withFilter.Key, "The key should hold both branches, whichever is taken.") + + [] + member _.``The other branch of a choice must not be computed when the first one is taken`` () = + let flag = true + let filter : string option = None + let limit = 18 + + let shape = + ParameterizerAssert.WantShape <@ fun (p : Person) -> if flag then p.Age > limit else p.Name = filter.Value @> + + CollectionAssert.AreEqual ( + [| ValueSome (box true); ValueSome (box 18); ValueNone |], + shape.Values |> Seq.toArray, + "The branch that is taken has its value, the other one has none." + ) + + [] + member _.``A branch inside a branch that is not taken must not be computed`` () = + let flag = false + let filter : string option = None + + let shape = + ParameterizerAssert.WantShape <@ fun (p : Person) -> flag && (filter.Value.Length > 3 || p.Name = filter.Value) @> + + CollectionAssert.AreEqual ( + [| ValueSome (box false); ValueNone; ValueNone |], + shape.Values |> Seq.toArray, + "Nothing under a branch that is not taken is computed, whatever its own conditions are." + ) + + [] + member _.``A condition that is one slot at two places must decide its branch at each of them`` () = + let flag = false + let filter : string option = None + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let enabled = flag + (enabled && p.Name = filter.Value) + || (enabled && p.Name = filter.Value.Trim ()) + @> + + CollectionAssert.AreEqual ( + [| ValueSome (box false); ValueNone; ValueNone |], + shape.Values |> Seq.toArray, + "The slot of the flag is found again at the second place, and there too it should keep its branch from being computed." + ) + + [] + member _.``A condition that Query.constant makes a constant must decide its branch`` () = + let shapeOf (flag : bool) (filter : string option) = + ParameterizerAssert.WantShape <@ fun (p : Person) -> Query.constant flag || p.Name = filter.Value.Trim () @> + + CollectionAssert.AreEqual ( + [| (ValueNone : objnull voption) |], + (shapeOf true None).Values |> Seq.toArray, + "The constant is true, so the other branch is not taken and nothing of it is computed." + ) + + CollectionAssert.AreEqual ( + [| ValueSome (box "Bob") |], + (shapeOf false (Some " Bob ")).Values |> Seq.toArray, + "The constant is false, so the other branch is taken and its part is computed." + ) + + [] + member _.``A condition that is the default value of a boolean must leave no branch to compute`` () = + let filter : string option = None + let shape = + ParameterizerAssert.WantShape <@ fun (p : Person) -> bool () && p.Name = filter.Value.Trim () @> + + Assert.IsEmpty ( + shape.Values, + "The condition is false in the quotation itself, so its branch is gone from the normal form and nothing of it is computed." + ) + + [] + member _.``A choice by the document must have both its branches computed`` () = + let limit = 18 + + let shape = + ParameterizerAssert.WantShape <@ fun (p : Person) -> if p.Active then p.Age > limit + 1 else p.Age > limit + 2 @> + + CollectionAssert.AreEqual ( + [| ValueSome (box 19); ValueSome (box 20) |], + shape.Values |> Seq.toArray, + "Which branch is taken is known only for a document, so the query needs the values of both." + ) + + [] + member _.``A part of a branch that is not taken must be computed when it is used outside the branch too`` () = + let flag = false + let meter = Meter () + + let shape = + ParameterizerAssert.WantShape + <@ + fun (p : Person) -> + let name = meter.Read "Bob" + (flag && p.Name = name) || p.Nick = Some name + @> + + CollectionAssert.AreEqual ( + [| ValueSome (box false); ValueSome (box "Bob") |], + shape.Values |> Seq.toArray, + "The second use is in a branch that is taken, so the slot of both uses needs its value." + ) + + Assert.AreEqual(1, meter.Readings, "The code of the value should run once.") + + [] + member _.``Query.constant must be computed in a branch that is not taken`` () = + let meter = Meter () + let keyOf (flag : bool) = + (ParameterizerAssert.WantShape <@ fun (p : Person) -> flag || p.Age > Query.constant (meter.Read 18) @>).Key + + let taken = keyOf false + let readings = meter.Readings + let notTaken = keyOf true + + Assert.AreEqual(taken, notTaken, "A constant is a part of the key, so the key needs it in either case.") + Assert.AreEqual(readings + 1, meter.Readings, "The constant should be computed although its branch is not taken.") + + // The key + + [] + member _.``The key must list the nodes of the quotation, every node before the nodes under it`` () = + let limit = 18 + let quotation = <@ fun (p : Person) -> p.Age > limit || p.Name = "Bob" @> + let shape = ParameterizerAssert.WantShape quotation + + let struct (greaterThan, age, equals, name) = + match quotation with + | Lambda (_, + IfThenElse (Call (None, greaterThan, [ PropertyGet (_, age, _); _ ]), + _, + Call (None, equals, [ PropertyGet (_, name, _); _ ]))) -> + struct (greaterThan, age, equals, name) + | other -> invalidOp $"The quotation is not the two comparisons it was written as: %A{other}" + + let token (kind : ShapeTokenKind) (number : int) (subject : objnull) (detail : objnull) : ShapeToken = { + Kind = kind + Number = number + Subject = subject + Detail = detail + } + + CollectionAssert.AreEqual ( + [| + token ShapeTokenKind.Lambda 0 typeof null + token ShapeTokenKind.IfThenElse 0 null null + token ShapeTokenKind.Call 0 greaterThan null + token ShapeTokenKind.PropertyGet 0 age null + token ShapeTokenKind.Variable 0 null null + token ShapeTokenKind.Slot 0 typeof "limit" + token ShapeTokenKind.Constant 0 typeof true + token ShapeTokenKind.Call 0 equals null + token ShapeTokenKind.PropertyGet 0 name null + token ShapeTokenKind.Variable 0 null null + token ShapeTokenKind.Constant 0 typeof "Bob" + |], + shape.Key.Tokens |> Seq.toArray, + "The key should hold the function, the choice that `||` is, and each comparison with what it compares." + ) + + Assert.HasCount ( + shape.Key.Tokens.Length, + (string shape.Key).Split('\n', StringSplitOptions.RemoveEmptyEntries), + "The key should be written with one token on a line." + ) + + [] + member _.``Two keys with one hash code must be told apart by their tokens`` () = + let keyOf (token : ShapeToken) : ShapeKey = { + Tokens = System.Collections.Immutable.ImmutableArray.Create token + Hash = 1 + } + + let token : ShapeToken = { + Kind = ShapeTokenKind.Constant + Number = 0 + Subject = typeof + Detail = 18 + } + + Assert.AreEqual(keyOf token, keyOf token, "Keys with equal tokens are equal, whichever arrays hold the tokens.") + + // A hash code is only the first thing two keys are compared by: after it, everything a token says counts. + Assert.AreNotEqual( + keyOf token, + keyOf { token with Kind = ShapeTokenKind.Slot }, + "Tokens of different kinds are different tokens." + ) + + Assert.AreNotEqual(keyOf token, keyOf { token with Number = 1 }, "The number of a token is a part of it.") + + Assert.AreNotEqual( + keyOf token, + keyOf { token with Subject = typeof }, + "The subject of a token is a part of it." + ) + + Assert.AreNotEqual(keyOf token, keyOf { token with Detail = 21 }, "The detail of a token is a part of it.") + + [] + member _.``A variable must be in the key as the distance to its binding`` () = + let keyOf (expr : Expr) = (ParameterizerAssert.WantShape expr).Key + let outer = keyOf <@ fun (first : int) (second : int) -> first @> + let inner = keyOf <@ fun (first : int) (second : int) -> second @> + let renamed = keyOf <@ fun (a : int) (b : int) -> a @> + + Assert.AreNotEqual(outer, inner, "Functions that return different variables are different functions.") + Assert.AreEqual(outer, renamed, "The names of the variables are not in the key.") + + [] + member _.``A struct tuple and a reference tuple must have different keys`` () = + let keyOf (expr : Expr) = (ParameterizerAssert.WantShape expr).Key + + Assert.AreNotEqual( + keyOf <@ fun (p : Person) -> (p.Name, p.Age) @>, + keyOf <@ fun (p : Person) -> struct (p.Name, p.Age) @>, + "The two kinds of tuples can be written into a document in different ways, so they are different queries." + ) + + [] + member _.``A variable of a delegate must be in the key as the distance to its binding`` () = + let keyOf (expr : Expr) = (ParameterizerAssert.WantShape expr).Key + let first = keyOf <@ Func(fun first second -> first) @> + let second = keyOf <@ Func(fun first second -> second) @> + let renamed = keyOf <@ Func(fun a b -> a) @> + + Assert.AreNotEqual(first, second, "Delegates that return different variables are different delegates.") + Assert.AreEqual(first, renamed, "The names of the variables are not in the key.") + + [] + member _.``A captured value inside a delegate must be a slot`` () = + let name = "vip" + + let template = + ParameterizerAssert.WantTemplate <@ fun (p : Person) -> Enumerable.Any (p.Tags, (fun tag -> tag = name)) @> + + let slot = Assert.ContainsSingle (template.Slots, "The delegate captures one value.") + Assert.AreEqual(ValueSome "name", slot.Name, "The slot should have the name of the variable.") + + CollectionAssert.AreEqual ( + [| slot.Variable |], + template.Body.GetFreeVars () |> Seq.toArray, + "The delegate should be built anew around the variable of the slot." + ) + + [] + member _.``A key that no code has filled must be equal to itself and hold no token`` () = + let empty = Unchecked.defaultof + + Assert.AreEqual(empty, Unchecked.defaultof, "A key without tokens is a key like any other.") + Assert.AreEqual("", string empty, "It should be written as no tokens, not fail.") + + [] + member _.``A quotation without slots must be its own template`` () = + let normal = NormalizerAssert.WantNormal <@ fun (p : Person) -> p.Age > 18 @> + let template = + Assert.WantOk (Parameterizer.templateOf normal, "A quotation of literals has a template.") + + Assert.AreSame(normal, template.Body, "Nothing is replaced, so no node should be built.") + + // Errors + + [] + member _.``A function value in the place of a value of the query must be reported`` (quotation : Expr) = + let error = ParameterizerAssert.WantError quotation + + Assert.AreEqual( + TranslationErrorCode.CapturedFunctionValue, + error.Code, + "A compiled function can be neither read nor passed as a parameter." + ) + + Assert.IsNotEmpty (error.Hints, "The error should say what to write instead.") + Assert.IsValueSome (error.Location, "The function was passed in this file, so the error has its place.") + + [] + member _.``A value that is no literal must not be made a constant`` (quotation : Expr) = + let error = ParameterizerAssert.WantError quotation + + Assert.AreEqual( + TranslationErrorCode.Unsupported, + error.Code, + "The key holds a constant, and only a literal says by its equality what a query writes for it." + ) + + Assert.Contains ( + "Query.constant", + error.Message, + StringComparison.Ordinal, + "The message should name the function that was given the value." + ) + + Assert.Contains ( + "the null of a reference type that is no union of F#, as an option is", + error.Message, + StringComparison.Ordinal, + "The message should not call a case of a union that is null a literal: it is the null of a reference type, and two of these rows." + ) + + Assert.IsNotEmpty (error.Hints, "The error should say what to write instead.") + Assert.IsValueSome (error.Location, "The call was written in this file, so the error has its place.") + + [] + member _.``Code that raises an exception must be reported with the exception as the cause`` () = + let zero = 0 + let error = ParameterizerAssert.WantError <@ fun (p : Person) -> p.Age > 10 / zero @> + + Assert.AreEqual( + TranslationErrorCode.ClientEvaluationFailed, + error.Code, + "The part has to be computed, and computing it failed." + ) + + let cause = Assert.WantValueSome (error.Cause, "The error should carry the exception.") + Assert.IsInstanceOfType (cause, typeof, "The cause should be the exception of the division.") + + [] + member _.``Query.constant of code that raises an exception must be reported`` () = + let zero = 0 + let error = ParameterizerAssert.WantError <@ fun (p : Person) -> p.Age > Query.constant (10 / zero) @> + + Assert.AreEqual( + TranslationErrorCode.ClientEvaluationFailed, + error.Code, + "The constant has to be computed, and computing it failed." + ) + + [] + [] + [] + member _.``A function of Query over a value of the document must be reported`` (isConstant : bool) = + let struct (name, quotation) = + if isConstant then + struct ("Query.constant", <@@ fun (p : Person) -> p.Age > Query.constant p.Age @@>) + else + struct ("Query.parameter", <@@ fun (p : Person) -> p.Age > Query.parameter p.Age @@>) + + let error = ParameterizerAssert.WantError quotation + + Assert.AreEqual( + TranslationErrorCode.Unsupported, + error.Code, + "A value of the document is not known before the query runs." + ) + + Assert.Contains (name, error.Message, StringComparison.Ordinal, "The message should name the function.") + Assert.IsNotEmpty (error.Hints, "The error should say what to write instead.") + + [] + member _.``A variable that nothing binds must be reported`` () = + let stray = Var ("stray", typeof) + let quotation = <@ fun (p : Person) -> p.Age > %%(Expr.Var stray) @> + let error = ParameterizerAssert.WantError quotation + + Assert.AreEqual(TranslationErrorCode.Unsupported, error.Code, "The variable has no value.") + Assert.Contains ("stray", error.Message, StringComparison.Ordinal, "The message should name the variable.") + + [] + member _.``A quotation inside the quotation must be reported`` () = + let person = Var ("p", typeof) + let quotation = Expr.Lambda (person, Expr.QuoteTyped <@@ 1 @@>) + + let error = + Assert.WantError (Parameterizer.shapeOf quotation, "A quotation is neither a value nor an operation on the document.") + + Assert.AreEqual(TranslationErrorCode.Unsupported, error.Code, "A query cannot express it.") diff --git a/tests/Cosmos.Quotations.Tests/QuotationAssert.fs b/tests/Cosmos.Quotations.Tests/QuotationAssert.fs new file mode 100644 index 00000000..43925f8b --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/QuotationAssert.fs @@ -0,0 +1,244 @@ +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 + +// The functions of FSharp.Core that give an option or reference tuples are shadowed there. So are the cases of a +// result, by the results of the item operations, which is why a result is matched with its full case names here. +open FSharp.Azure.Cosmos +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// Questions about a quotation that the assertions and the tests ask. +[] +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 + | Result.Ok normal -> normal + | Result.Error error -> + raise ( + AssertFailedException + $"The quotation should have a normal form, but: %s{error.Message}\n%s{error.Fragment}\n%A{expr}" + ) + + /// + /// The error the normalizer reports for ; fails when it gives a normal form. + /// + let WantError (expr : Expr) : TranslationError = + match Normalizer.normalize expr with + | Result.Ok normal -> + raise (AssertFailedException $"The quotation should be an error, but has the normal form\n%A{normal}") + | Result.Error error -> error + + /// + /// Asserts that and are the same quotation up to their bound + /// 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}" + ) + +/// Questions about a template that the tests ask. +[] +module internal Templates = + + /// + /// The quotation of with the value of every slot at the place of its variable, which + /// is a quotation that can be evaluated again. A slot without a value gets the default value of its type: it is in + /// a branch that is not taken, so nothing reads it. + /// + let withValues (template : Template) : Expr = + template.Body.Substitute (fun variable -> + template.Slots + |> Seq.tryFindIndex (fun slot -> obj.ReferenceEquals (slot.Variable, variable)) + |> ValueOption.map (fun index -> + match template.Values[index] with + | ValueSome value -> Expr.Value (value, variable.Type) + | ValueNone -> Expr.DefaultValue variable.Type + ) + // The substitution of FSharp.Core takes an option. + |> ValueOption.toOption + ) + +/// Assertions on what the parameterizer makes of a quotation. +[] +module internal ParameterizerAssert = + + /// + /// The shape of the normal form of ; fails when the parameterizer reports an error. + /// + let WantShape (expr : Expr) : Shape = + Assert.WantOk ( + expr |> NormalizerAssert.WantNormal |> Parameterizer.shapeOf, + $"The quotation should have a shape.\n%A{expr}" + ) + + /// + /// The template of the normal form of ; fails when the parameterizer reports an error. + /// + let WantTemplate (expr : Expr) : Template = + Assert.WantOk ( + expr + |> NormalizerAssert.WantNormal + |> Parameterizer.templateOf, + $"The quotation should have a template.\n%A{expr}" + ) + + /// + /// The error that the parameterizer reports for the normal form of ; fails when it gives a + /// result, and when it reports one error for the shape and another for the template. + /// + let WantError (expr : Expr) : TranslationError = + let normal = NormalizerAssert.WantNormal expr + let ofShape = + Assert.WantError (Parameterizer.shapeOf normal, $"The quotation should have no shape.\n%A{expr}") + + let ofTemplate = + Assert.WantError (Parameterizer.templateOf normal, $"The quotation should have no template.\n%A{expr}") + + Assert.AreEqual(ofShape.Code, ofTemplate.Code, "The shape and the template should fail alike.") + Assert.AreEqual(ofShape.Message, ofTemplate.Message, "The shape and the template should fail alike.") + ofShape diff --git a/tests/Cosmos.Quotations.Tests/TestCategories.fs b/tests/Cosmos.Quotations.Tests/TestCategories.fs new file mode 100644 index 00000000..797d5ccb --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/TestCategories.fs @@ -0,0 +1,39 @@ +// 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 evaluator of the parts of a quotation that read no variable: +/// . +/// +type EvaluatorUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Evaluator" |] :> IList + +/// +/// Categorizes a unit test of the normalizer: +/// , +/// and +/// . +/// +type NormalizerUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Normalizer" |] :> IList + +/// +/// Categorizes a unit test of the parameterizer, which tells the shape of a quotation from the values it was written +/// with: and +/// . +/// +type ParameterizerUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Parameterizer" |] :> IList 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