diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index 46978db5..432834f2 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -12,6 +12,13 @@ ```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 +│ └── JsonLayout.fs – how the serializer writes the members of a document: their names and what a member without a value is ├── src/Cosmos/ – main library (FSharp.Azure.Cosmos) │ ├── SubStatusCodes.fs – documented Cosmos DB sub-status codes │ ├── Cosmos.fs – core types and container extensions @@ -28,6 +35,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 @@ -39,6 +47,7 @@ * [`FSharp.Control.TaskSeq`](https://github.com/fsprojects/FSharp.Control.TaskSeq) – `IAsyncEnumerable` / `taskSeq` support * [`FSharp.Control.Reactive`](https://github.com/fsprojects/FSharp.Reactive) – Rx extensions for F# * [`FsToolkit.ErrorHandling`](https://github.com/demystifyfp/FsToolkit.ErrorHandling) – `taskResult`, `Result`, `voption` CEs +* [`FSharp.SystemTextJson`](https://github.com/Tarmil/FSharp.SystemTextJson) – F# types in `System.Text.Json`; `FSharp.Azure.Cosmos.Quotations` reads its options to know how documents are written * [`Unquote`](https://github.com/SwensenSoftware/unquote) – test assertions * [`MSTest`](https://github.com/microsoft/testfx) – test framework diff --git a/Directory.Packages.props b/Directory.Packages.props index 69f8e798..279a2585 100644 --- a/Directory.Packages.props +++ b/Directory.Packages.props @@ -8,6 +8,7 @@ + diff --git a/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..f393e3e0 --- /dev/null +++ b/src/Cosmos.Quotations/FSharp.Azure.Cosmos.Quotations.fsproj @@ -0,0 +1,40 @@ + + + + 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/JsonLayout.fs b/src/Cosmos.Quotations/JsonLayout.fs new file mode 100644 index 00000000..11e1cdd1 --- /dev/null +++ b/src/Cosmos.Quotations/JsonLayout.fs @@ -0,0 +1,1750 @@ +namespace FSharp.Azure.Cosmos.Quotations + +open System +open System.Collections.Concurrent +open System.Collections.Generic +open System.Collections.Immutable +open System.Reflection +open System.Text.Json +open System.Text.Json.Serialization +open System.Text.Json.Serialization.Metadata +open FSharp.Reflection + +open FSharp.Azure.Cosmos + +/// +/// How a member of a document is written when it has no value: an +/// or a +/// without one, a that is skipped, a +/// without a value or a reference that is . A query has to +/// know it to ask whether the member has a value. +/// +[] +type OptionalEncoding = + /// Without a value the member is written as null; with one, as the value itself. + | AlwaysNull + /// Without a value the member is left out of the document; with one, it is written as the value itself. + | AlwaysUndefined + /// + /// Without a value the member is written as null or left out, and the layout cannot tell which: a rule that it + /// cannot read decides, such as a + /// that code has set. With a value, the member is written as the value itself. + /// + | NullOrUndefined + /// + /// The layout does not describe how the value is written: as a union with the name of its case, which is what + /// FSharp.SystemTextJson writes for an option when UnwrapOption is off; by a converter that writes + /// something of its own for a value without a value, or that fails to write one; or not at all, because the + /// serializer refuses the type. + /// + | NotDescribed + +/// +/// A member of a document as a query reads it: a property or a field, and the type of the value that it is read from. +/// +/// +/// The member alone does not tell that type. A quotation names an inherited property as the type that declares it +/// has it, also when the property is read from a value of a derived type, and the serializer can write the two types +/// in different ways: one as an object, the other by a converter. +/// +[] +type DocumentMember = { + /// The type of the value that the member is read from. In a quotation it is the type of the receiver. + Holder : Type + /// The property or the field, as any type that has it names it. + Member : MemberInfo +} + +/// +/// How a value of an enumeration is written. A query has to know it to compare such values by their order and to test +/// their bits, which only a number allows. +/// +/// +/// The encoding is the kind of JSON value, and not what is written for one value of the enumeration: a naming policy +/// can spell a name, an attribute can declare one, and a converter of the application writes what it likes. So what +/// stands for such a value in a query has to come from the serializer: the encoding does not say it. +/// +[] +type EnumEncoding = + /// As the number under the value. + | Number + /// + /// As a JSON string: the name of the value in the spelling that its converter gives it, or what a converter of the + /// application writes for it. The converter of System.Text.Json writes a value that has no name, alone or as a + /// combination of flags, as its number even then, unless it was made to refuse such a value. + /// + | String + /// + /// The layout does not describe how the values are written: neither as numbers nor as strings, some as numbers + /// and others as strings, or not all of them because the converter refuses one. + /// + | NotDescribed + +/// +/// How a tuple is written. A query has to know it to read an item of a tuple that a document holds. +/// +[] +type TupleEncoding = + /// As a JSON array of the items in their order. A tuple of more than seven items is one array as well. + | Array + /// + /// As a JSON object with a property for every item that the serializer writes. + /// + /// names the property of a member of the tuple type, such as Item1, and has no name for an item that is + /// not written. System.Text.Json writes a tuple this way; the items after the seventh are those of the tuple in + /// Rest. + /// + | Object + /// The layout does not describe how the tuple is written: a converter that it does not know writes it. + | NotDescribed + +/// +/// How a collection is written. A query has to know it to ask about the items of a collection that a document holds. +/// +[] +type CollectionEncoding = + /// + /// As a JSON array with an item for every item of the collection. + /// + /// The type of an item. + | Array of element : Type + /// + /// Not as an array of its items, or the layout does not know how: an array of bytes is written as one text, and a + /// converter that the layout does not know can write anything. + /// + | NotDescribed + +/// +/// How a map or a dictionary is written. A query has to know it to look a key up in a map that a document holds. +/// +[] +type MapEncoding = + /// + /// As a JSON object with a property for every key. + /// + /// The type of a key. + /// The type of a value. + | Object of key : Type * value : Type + /// + /// As a JSON array with an item for every key, which is an array of the key and its value. FSharp.SystemTextJson + /// writes a map this way when its keys are no texts. + /// + /// The type of a key. + /// The type of a value. + | ArrayOfPairs of key : Type * value : Type + /// The layout does not describe how the map is written: a converter that it does not know writes it. + | NotDescribed + +/// +/// A step from a JSON value to a value that it holds. The steps to a part of a union start at the value of the union. +/// +[] +type JsonStep = + /// + /// To the property of a JSON object that has this name. + /// + /// The name of the property. + | Property of name : string + /// + /// To the item of a JSON array at this index. + /// + /// The index of the item, counted from zero. + | Item of index : int + +/// +/// What a union writes to name a case. FSharp.SystemTextJson writes the name of the case, and the number or the +/// boolean that a case declares in place of a name with +/// . +/// +[] +type UnionTag = + /// + /// A JSON string. + /// + /// The string. + | String of text : string + /// + /// A JSON number. + /// + /// The number. + | Number of number : int + /// + /// A JSON boolean. + /// + /// The boolean. + | Boolean of flag : bool + +/// +/// What tells that a value of a union is of one case. A query has to know it to ask for the values of a case. +/// +[] +type UnionCaseMark = + /// + /// The JSON value at the end of is . With no step the value of the + /// union itself is the tag, as for a case without fields that is written as its name alone. + /// + /// The steps from the value of the union to the tag. + /// The tag of the case. + | Tag of path : ImmutableArray * tag : UnionTag + /// + /// The value of the union is a JSON object that has a property of this name, which holds the fields of the case. + /// + /// The name of the property. + | Property of name : string + /// + /// The value of the union is : the case is the one that a union marked with + /// represents by null. + /// + /// says how a member that holds such a null is written. + /// + | Null + /// + /// Nothing that is written tells the case: the union is written without tags, or it has one case, whose one + /// field is written in place of the union. + /// + | Unmarked + +/// +/// Where the value of a field of a union case is written. +/// +[] +type UnionFieldPlace = + /// + /// The value of the field is the JSON value at the end of . With no step it is written in + /// place of the union. + /// + /// The steps from the value of the union to the value of the field. + | Value of path : ImmutableArray + /// + /// The field is a record, and its members are properties of the JSON object at the end of + /// , which holds the tag of the case next to them: the object is more than the record. + /// + /// names the property of a member of the record. + /// + /// The steps from the value of the union to the object that holds the members. + | Members of path : ImmutableArray + +/// +/// How a value of one case of a union is written. A query has to know it to test the case of a union that a document +/// holds and to read a field of that case. +/// +[] +type UnionCaseEncoding = + /// + /// The case is written in the way that is described. + /// + /// What tells that a value is of this case. + /// Where the fields of the case are written, in the order of the fields. + | Written of mark : UnionCaseMark * fields : ImmutableArray + /// + /// The layout does not describe how the case is written: the serializer refuses the union, a converter that the + /// layout does not know writes it, or it is an option, a value option or a skippable value that is written as + /// its value, which + /// + /// describes. + /// + | NotDescribed + +/// +/// What a query has to know about how documents were serialized. The translator asks it for every member that a +/// quotation reads, so that the query reads the property that the serializer wrote, and for every value that is no +/// JSON object by itself: an enumeration, a tuple, a collection, a map and a union are each written in more than one +/// way. +/// +/// +/// +/// gives the layout of System.Text.Json with or without FSharp.SystemTextJson. A layout of another serializer +/// implements this interface. +/// +type IJsonLayout = + + /// + /// The name of the JSON property that holds , a property or a field of a type + /// that is written as a JSON object; no value when the documents hold no such property, as far as the layout can + /// tell. + /// + /// + /// A member that the serializer never writes has a name all the same when the name is declared on it, with + /// : such a member stands for a property + /// that something else writes into the document, as a type discriminator or a computed property is. + /// + abstract MemberName : memberOfDocument : DocumentMember -> string voption + + /// + /// How a value of is written when it has no value: an option, a value option, a + /// , a nullable or a reference. + /// + /// + /// A member can name a converter of its own. The serializer leaves a reference or a nullable of such a member + /// out, or writes it as , before it asks that converter, so the member is described as any + /// other, unless the converter asks for the null itself and writes something else for it. With a value the + /// member is what its converter writes. + /// An option, a value option or a skippable value of such a member is not described: the converter writes all of + /// it. + /// + /// + /// The member that holds the value, when it is a member of a type written as a JSON object: a member can be left + /// out. No value for an item of a collection or of a tuple that is written as an array, which is always written. + /// + /// The type of the value, which is the type of the member when there is one. + abstract OptionalEncoding : memberOfDocument : DocumentMember voption * valueType : Type -> OptionalEncoding + + /// + /// How a value of the enumeration is written. + /// + /// + /// + /// This member and the three after it are asked alike. is the member that + /// holds the value, when it is a member of a type written as a JSON object: a member can name a converter of its + /// own, which writes its value and no other. It has no value for an item of a collection and for an item of a + /// tuple that is written as an array, which no member holds. + /// + /// + /// The type that is asked about is the type of the member, or the type under an option, a value option, a + /// skippable value or a nullable that the member is: what + /// + /// says of the member tells whether the value under it is written as itself. A converter of the member writes + /// the whole value of the member, so with such a converter only the type of the member, or the type that the + /// member is a nullable of, is described. + /// + /// + /// A member that the serializer never writes is not described: something else writes its property, in a way of + /// its own. + /// + /// + /// The member that holds the value, when a member does. + /// The type of the value: an enumeration, or a nullable of one. + abstract EnumEncoding : memberOfDocument : DocumentMember voption * enumType : Type -> EnumEncoding + + /// + /// How a value of the tuple type is written. It is asked as + /// + /// is. + /// + /// The member that holds the tuple, when a member does. + /// The type of the tuple, a struct tuple or a reference tuple. + abstract TupleEncoding : memberOfDocument : DocumentMember voption * tupleType : Type -> TupleEncoding + + /// + /// How a value of is written, when it is a collection. It is asked as + /// + /// is. + /// + /// The member that holds the collection, when a member does. + /// The type of the collection. + abstract CollectionEncoding : memberOfDocument : DocumentMember voption * collectionType : Type -> CollectionEncoding + + /// + /// How a value of is written, when it is a map or a dictionary. It is asked as + /// + /// is. + /// + /// The member that holds the map, when a member does. + /// The type of the map. + abstract MapEncoding : memberOfDocument : DocumentMember voption * mapType : Type -> MapEncoding + + /// + /// How a value of the union case is written: what tells that a value is of the case, and + /// where its fields are. The union is the one that declares the case. It is asked as + /// + /// is. + /// + /// + /// + /// A member that names a converter of its own is not described: nothing shows how that converter writes a union. + /// + /// + /// Neither is a union one of whose cases is written as an object with two properties of the name of the tag, the + /// tag and a field: a query reads one property of a name, and nothing says which of the two. + /// + /// + /// The member that holds the union, when a member does. + /// The case. + abstract UnionCaseEncoding : memberOfDocument : DocumentMember voption * case : UnionCaseInfo -> UnionCaseEncoding + +/// +/// The layouts of the serializers that comes with. +/// +[] +module JsonLayout = + + /// The members of a type whatever their accessibility: a record of the caller may be internal or private. + [] + let private AnyAccessibility = BindingFlags.Public ||| BindingFlags.NonPublic + + /// The assembly of System.Text.Json, whose own converters are the ones that it documents. + let private serializerAssembly = typeof.Assembly + + /// The assembly of FSharp.SystemTextJson, whose own converters are the ones whose way to write is known here. + let private fsharpSerializerAssembly = typeof.Assembly + + /// + /// Whether is + /// or a class that is derived from it. + /// + let rec private isDerivedFromTupleConverter (converterType : Type | null) : bool = + match converterType with + | null -> false + | converterType -> + (converterType.IsGenericType + && Type.(=) (converterType.GetGenericTypeDefinition (), typedefof>)) + || isDerivedFromTupleConverter converterType.BaseType + + /// + /// Whether is one of the converters of FSharp.SystemTextJson for tuples: it has a + /// class for two, three and four items of either kind of tuple and one for every other number, and + /// is the base of all of them. + /// + /// + /// The base class is public, and so are the classes of the library that are derived from it: a converter of an + /// application can be derived from any of them and write a tuple in a way of its own. So only a class of the + /// library itself is one of its converters. + /// + let private isTupleConverter (converterType : Type) : bool = + converterType.Assembly.Equals fsharpSerializerAssembly + && isDerivedFromTupleConverter converterType + + /// Whether the steps of begin with the steps of . + let private beginsWith (start : ImmutableArray) (path : ImmutableArray) : bool = + path.Length >= start.Length + && path.AsSpan(0, start.Length).SequenceEqual(start.AsSpan ()) + + /// + /// The kinds of values that can be absent, as far as the way they are written depends on the kind. + /// + [] + type private OptionalKind = + /// An option: without a value it is a null reference. + | Option + /// A value option: a struct, so without a value it is not null but the default value of its type. + | ValueOption + /// The skippable value of FSharp.SystemTextJson: a struct like a value option. + | Skippable + /// A nullable or a reference: written as itself or as null. + | Nullable + /// A value type that always has a value. + | Never + + /// + /// Whether is made of the generic type . + /// + let private isMadeOf (definition : Type) (valueType : Type) : bool = + valueType.IsGenericType + && Type.(=) (valueType.GetGenericTypeDefinition (), definition) + + /// + /// The kind of . + /// + let private optionalKindOf (valueType : Type) : OptionalKind = + if isMadeOf typedefof<_ option> valueType then + OptionalKind.Option + elif isMadeOf typedefof<_ voption> valueType then + OptionalKind.ValueOption + elif isMadeOf typedefof> valueType then + OptionalKind.Skippable + elif not valueType.IsValueType then + OptionalKind.Nullable + elif isMadeOf typedefof> valueType then + OptionalKind.Nullable + else + OptionalKind.Never + + /// + /// Whether itself carries an attribute of the type + /// . An attribute of a declaration that the member overrides does not count: the + /// serializers do not read it for the override. + /// + let private isMarked (attributeType : Type) (memberOfDocument : MemberInfo) : bool = + memberOfDocument.IsDefined (attributeType, false) + + /// + /// The name that declares for itself, when it does: the first name of the + /// of FSharp.SystemTextJson, which that library + /// reads before the of System.Text.Json. + /// The attributes of the member itself count, and not those of a declaration that it overrides: the serializers + /// read them that way. + /// + /// Whether the type of the member is written by FSharp.SystemTextJson. + /// The member. + let private declaredNameOf (readsJsonName : bool) (memberOfDocument : MemberInfo) : string voption = + let ofJsonName = + if readsJsonName then + memberOfDocument.GetCustomAttributes false + // A name with a field is the name of a field of a union case, not of this member. The library + // declares the field as a string that is never null and leaves it null when none is given. + |> Seq.tryFind (fun attribute -> + match withNull attribute.Field with + | null -> true + | _ -> false + ) + |> ValueOption.map _.Name.AsString() + else + ValueNone + + ofJsonName + |> ValueOption.orElseWith (fun () -> + match memberOfDocument.GetCustomAttribute false with + | null -> ValueNone + | attribute -> ValueSome attribute.Name + ) + + /// + /// Whether and are one member, also when one of them was asked + /// for through a derived class. + /// + let private isSameMember (first : MemberInfo) (second : MemberInfo) : bool = + first.MetadataToken = second.MetadataToken + && first.Module.Equals second.Module + && Type.(=) (first.DeclaringType, second.DeclaringType) + + /// + /// Whether is the property as a derived class overrides + /// it. A quotation names a property that is overridden as the class that declares it first has it, and the + /// contract of the derived class lists the override. + /// + let private isOverrideOf (declared : MemberInfo) (candidate : MemberInfo) : bool = + match declared, candidate with + | (:? PropertyInfo as declared), (:? PropertyInfo as candidate) -> + match declared.GetMethod, candidate.GetMethod with + | null, _ + | _, null -> false + | declaredGetter, candidateGetter -> + isSameMember (declaredGetter.GetBaseDefinition ()) (candidateGetter.GetBaseDefinition ()) + | _ -> false + + /// + /// Whether a union type has a case that is represented by . To FSharp.SystemTextJson such a + /// null is a value that can be left out, while a null of any other union is not. + /// + let private hasNullCase (unionType : Type) : bool = + unionType.GetCustomAttributes (typeof, false) + |> Seq.cast + |> Seq.exists _.Flags.HasFlag(CompilationRepresentationFlags.UseNullAsTrueValue) + + /// + /// with what it has answered kept: a question is answered once, and every later asking + /// gets the answer that was found. + /// + /// + /// An answer of a layout is a fact of the options, and finding it out asks the serializer, which can run code of + /// the application: a converter factory, a modifier of a contract. + /// can run + /// its function more than once for a key that several threads ask for at a time, so what is kept for a question + /// is the answer as a , which is computed by one of them. + /// + let private remembered (answer : 'Question -> 'Answer) : 'Question -> 'Answer = + let answers = ConcurrentDictionary<'Question, Lazy<'Answer>>() + let create = Func<'Question, Lazy<'Answer>>(fun question -> lazy answer question) + fun question -> answers.GetOrAdd(question, create).Value + + /// + /// What FSharp.SystemTextJson reads from its options and from the options of the serializer when it writes the + /// fields of a record. + /// + [] + type private RecordOptions = { + /// The naming policy for a field that declares no name; none when names are written as they are. + NamingPolicy : JsonNamingPolicy | null + /// Whether a reference that is null is left out: the serializer ignores null values. + IgnoresNull : bool + /// When an option without a value is left out. + SkippableOptionFields : SkippableOptionFields + /// Whether the properties of a record that are not its fields are written too. + IncludesProperties : bool + /// How unions are written: a union that is written as the one value it wraps is null where that value is. + UnionEncoding : JsonUnionEncoding + /// Whether a field of any type may be null in a document. + AllowsNullFields : bool + } + + /// + /// Whether a type is no union, record or tuple of F#. FSharp.SystemTextJson leaves a null of such a type out when + /// null values are ignored, and writes a null of the other types. + /// + let private isNoTypeOfFSharp (valueType : Type) : bool = + not ( + FSharpType.IsUnion (valueType, AnyAccessibility) + || FSharpType.IsRecord (valueType, AnyAccessibility) + || FSharpType.IsTuple valueType + ) + + /// + /// Whether FSharp.SystemTextJson has a value of that it reads from a null. A null of + /// such a type is a value to the library, which leaves it out when null values are ignored. The rules are the + /// ones of the function of the library that finds that value. + /// + /// The options of the record whose field is asked about. + /// The type of the field. + let rec private hasNullValue (recordOptions : RecordOptions) (valueType : Type) : bool = + let isOption = + isMadeOf typedefof<_ option> valueType + || isMadeOf typedefof<_ voption> valueType + + if hasNullCase valueType || Type.(=) (valueType, typeof) then + true + elif + isMadeOf typedefof<_ voption> valueType + && recordOptions.UnionEncoding.HasFlag JsonUnionEncoding.UnwrapOption + then + true + elif + isMadeOf typedefof> valueType + || (isOption + && recordOptions.SkippableOptionFields = SkippableOptionFields.Always) + then + hasNullValue recordOptions (valueType.GetGenericArguments()[0]) + elif recordOptions.AllowsNullFields && isNoTypeOfFSharp valueType then + true + else + // A union of one case with one field that is written as that field is null where the field is. + recordOptions.UnionEncoding.HasFlag JsonUnionEncoding.UnwrapSingleCaseUnions + && FSharpType.IsUnion (valueType, AnyAccessibility) + && ( + match FSharpType.GetUnionCases (valueType, AnyAccessibility) with + | [| case |] -> + match case.GetFields () with + | [| field |] -> hasNullValue recordOptions field.PropertyType + | _ -> false + | _ -> false + ) + + /// + /// The options that FSharp.SystemTextJson makes the converter of one type with. + /// + [] + type private ConverterOptions = { + /// The options of FSharp.SystemTextJson for the type: the ones the type has for itself, or the common ones. + Effective : JsonFSharpOptions + /// The options of the converter among the options that takes the type; none when an attribute on the type + /// makes the converter by itself. + Common : JsonFSharpOptions voption + /// The naming policy of the options of the serializer that the converter is made with; none when names are + /// written as they are. + NamingPolicy : JsonNamingPolicy | null + /// Whether those options of the serializer ignore null values. + IgnoresNull : bool + } + + /// + /// What FSharp.SystemTextJson reads from its options and from the options of the serializer when it writes a + /// union. + /// + [] + type private UnionOptions = { + /// How unions are written, with the encoding that the options of a type inherit put in. + Encoding : JsonUnionEncoding + /// The name of the property that holds the tag of a case. + TagName : string + /// The name of the property that holds the fields of a case. + FieldsName : string + /// The naming policy for a case that declares no name; none when names are written as they are. + TagNamingPolicy : JsonNamingPolicy | null + /// The naming policy for a field that declares no name; none when names are written as they are. + FieldNamingPolicy : JsonNamingPolicy | null + /// + /// The common options, when the union is written with them and has none of its own: the ones of the + /// converter among the options that takes the union. A record that a case unwraps is written as that + /// converter writes it. + /// + Common : JsonFSharpOptions voption + } + + /// + /// The bits of that choose where the tag is. + /// + [] + let private UnionFormatBits = 0xFE + + /// + /// The bit of among those bits. + /// + [] + let private UntaggedBit = 0x08 + + /// + /// as spells it; as it is without a policy. + /// + let private spelled (policy : JsonNamingPolicy | null) (name : string) : string = + match policy with + | null -> name + | policy -> policy.ConvertName name + + /// + /// The tag that FSharp.SystemTextJson writes for a case: the first name of the + /// of the case that names no field, then the name + /// of its , then the name of the case as + /// spells it. A name that is declared is written as it is. + /// + let private unionTagOf (policy : JsonNamingPolicy | null) (case : UnionCaseInfo) : UnionTag = + let declared = + case.GetCustomAttributes typeof + |> Seq.cast + // The library declares the field as a string that is never null and leaves it null when none is given. + |> Seq.tryFind (fun attribute -> + match withNull attribute.Field with + | null -> true + | _ -> false + ) + + match declared with + | ValueSome attribute -> + match attribute.Name with + | JsonName.String text -> UnionTag.String text + | JsonName.Int number -> UnionTag.Number number + | JsonName.Bool flag -> UnionTag.Boolean flag + | ValueNone -> + match + case.GetCustomAttributes typeof + |> Seq.cast + |> Seq.tryHead + with + | ValueSome attribute -> UnionTag.String attribute.Name + | ValueNone -> UnionTag.String (spelled policy case.Name) + + /// + /// A tag as the name of a JSON property, which is how a union with external tags writes it. + /// + let private propertyNameOf (tag : UnionTag) : string = + match tag with + | UnionTag.String text -> text + | UnionTag.Number number -> string number + | UnionTag.Boolean true -> "true" + | UnionTag.Boolean false -> "false" + + /// + /// The names that FSharp.SystemTextJson writes the fields of a case under when it writes them as properties, in + /// the order of the fields. + /// + /// + /// A field has the name that F# gives it. With + /// a field that the + /// source does not name, Item or Item1, Item2 and so on, has the name of its type, and a + /// name that the case then has more than once gets the number of its occurrence. Under that name the case can + /// declare another one, with a that names the + /// field; a name without one is spelled by the policy. + /// + let private unionFieldNamesOf (options : UnionOptions) (case : UnionCaseInfo) : string array = + let fields = case.GetFields () + let occurrences = Dictionary StringComparer.Ordinal + + let own = + if options.Encoding.HasFlag JsonUnionEncoding.UnionFieldNamesFromTypes then + fields + |> Array.mapi (fun index field -> + let isUnnamed = + if fields.Length = 1 then + String.Equals (field.Name, "Item", StringComparison.Ordinal) + else + String.Equals (field.Name, $"Item%d{index + 1}", StringComparison.Ordinal) + + let name = if isUnnamed then field.PropertyType.Name else field.Name + + let occurrence = + match occurrences.TryGetValue name with + | true, seen -> seen + 1 + | _ -> 1 + + occurrences[name] <- occurrence + struct (name, occurrence) + ) + else + fields |> Array.map (fun field -> struct (field.Name, 1)) + + let declared = Dictionary StringComparer.Ordinal + + for attribute in Seq.cast(case.GetCustomAttributes typeof) do + match withNull attribute.Field with + | null -> () + | field -> declared[field] <- attribute.Name.AsString () + + own + |> Array.map (fun (struct (name, occurrence)) -> + let isRepeated = + match occurrences.TryGetValue name with + | true, seen -> seen > 1 + | _ -> false + + let name = + if occurrence = 1 && not isRepeated then + name + else + $"%s{name}%d{occurrence}" + + match declared.TryGetValue name with + | true, given -> given + | _ -> spelled options.FieldNamingPolicy name + ) + + // JsonSerializerOptions.IgnoreNullValues is obsolete, and System.Text.Json and FSharp.SystemTextJson still follow + // it, so the layout has to read it. This function is the one place that does. + #nowarn "44" + + /// + /// The condition on which leave a member out that has no condition of its own. + /// , the setting of old, stands for + /// ; the options refuse the two + /// settings together. + /// + let private defaultIgnoreConditionOf (options : JsonSerializerOptions) : JsonIgnoreCondition = + if options.IgnoreNullValues then + JsonIgnoreCondition.WhenWritingNull + else + options.DefaultIgnoreCondition + + #warnon "44" + + /// + /// Who writes the members of a type, which decides the rules that their names and their absence follow. + /// + [] + type private Writer = + /// System.Text.Json writes the type as an object, and its contract lists the properties. + | Serializer of JsonTypeInfo + /// FSharp.SystemTextJson writes the type as a record. + | Record of RecordOptions + /// A converter that the layout does not know writes the type, or the type is not written as an object. + | Unknown + + /// + /// The layout of what System.Text.Json writes with the options it is made of, with or without the converter of + /// FSharp.SystemTextJson among them. + /// + /// + /// The layout asks the serializer itself who writes a type: the contract that the options resolve for a type names + /// the converter. So the order of the converters, the kinds of types that FSharp.SystemTextJson is set to handle + /// and a converter that a type names in an attribute all count as they do when a document is written. + /// + [] + type private SerializerLayout (options : JsonSerializerOptions) = + + // A copy, so that the options of the caller stay as they are: the contract can be asked only from options + // that have a resolver and that are not changed any more. The resolver is the one of the caller, because a + // resolver cannot be copied: it can be any object. So the layout asks who the serializer asks, and a resolver + // of System.Text.Json takes no change after either has asked it, which keeps the two from disagreeing. + let contract = + let copy = + match options.TypeInfoResolver with + | null -> JsonSerializerOptions (options, TypeInfoResolver = DefaultJsonTypeInfoResolver ()) + | _ -> JsonSerializerOptions options + + copy.MakeReadOnly () + copy + + /// The condition on which the options leave a member out that has no condition of its own. + let defaultIgnoreCondition = defaultIgnoreConditionOf contract + + /// The contract of a type; none for a type that the serializer refuses. + let typeInfoOf (documentType : Type) : JsonTypeInfo voption = + try + ValueSome (contract.GetTypeInfo documentType) + with + | :? NotSupportedException + | :? InvalidOperationException + | :? ArgumentException + // FSharp.SystemTextJson makes its converters by reflection, so what one of them refuses a type with comes + // wrapped in this one: a union with a case that has two attributes with names is refused that way. + | :? TargetInvocationException -> ValueNone + + /// + /// The options that FSharp.SystemTextJson writes a record or a union type with: the ones the type is given in + /// the overrides, then the ones of the attribute on the type when the options allow that, then the common + /// ones. The common ones are those of the converter that takes the type, which is the first one among the + /// options that does, as the serializer chooses it: the options can hold several converters of + /// FSharp.SystemTextJson for different kinds of types. No value when nothing shows the options of the + /// converter: a converter that stands among the options by itself keeps them to itself, and so does one that + /// an attribute of the caller makes. + /// + let converterOptionsOf (valueType : Type) : ConverterOptions voption = + let ofAttribute () = + match valueType.GetCustomAttributes (typeof, true) with + | [||] -> ValueNone + | attributes -> ValueSome (attributes[0] :?> IJsonFSharpConverterAttribute).Options + + let ofOverrides (common : JsonFSharpOptions) = + // The library declares the overrides as never null and gives null when there are none. + match withNull (common.Overrides common) with + | null -> ValueNone + | overrides -> + match overrides.TryGetValue valueType with + | true, given -> ValueSome given + | _ when valueType.IsGenericType -> + match overrides.TryGetValue (valueType.GetGenericTypeDefinition ()) with + | true, given -> ValueSome given + | _ -> ValueNone + | _ -> ValueNone + + match contract.Converters |> Seq.tryFind _.CanConvert(valueType) with + // The factory of FSharp.SystemTextJson itself, and no class that an application derives from it: such a + // class can make the converter of a record with other options than the ones it shows. + | ValueSome (:? JsonFSharpConverter as factory) when Type.(=) (factory.GetType (), typeof) -> + let common = factory.Options + + let effective = + ofOverrides common + |> ValueOption.orElseWith (fun () -> if common.AllowOverride then ofAttribute () else ValueNone) + |> ValueOption.defaultValue common + + ValueSome { + Effective = effective + Common = ValueSome common + NamingPolicy = contract.PropertyNamingPolicy + IgnoresNull = defaultIgnoreCondition = JsonIgnoreCondition.WhenWritingNull + } + | ValueSome _ -> ValueNone + | ValueNone -> + // No converter among the options takes the type, so an attribute on the type made the converter. The + // attribute of FSharp.SystemTextJson shows the options it makes the converter with, and gives it + // options of the serializer of its own: no naming policy, and nothing is ignored. Any other attribute + // can make the converter with options that nothing shows. + ofAttribute () + |> ValueOption.map (fun effective -> { + Effective = effective + Common = ValueNone + NamingPolicy = null + IgnoresNull = false + }) + + /// + /// How FSharp.SystemTextJson writes unions with the options of a converter. + /// + /// + /// The options that a type has for itself can say that they inherit the encoding of unions, with + /// : the library then takes the whole + /// encoding from the common options, also the parts that the options of the type set. The options that the + /// attribute makes say so unless the attribute sets the whole encoding. + /// + let unionEncodingOf (found : ConverterOptions) : JsonUnionEncoding = + match found.Common with + | ValueSome common when found.Effective.UnionEncoding.HasFlag JsonUnionEncoding.Inherit -> common.UnionEncoding + | _ -> found.Effective.UnionEncoding + + /// What FSharp.SystemTextJson reads when it writes the fields of a record type. + let recordOptionsOf (recordType : Type) : RecordOptions voption = + converterOptionsOf recordType + |> ValueOption.map (fun found -> { + NamingPolicy = found.NamingPolicy + IgnoresNull = found.IgnoresNull + SkippableOptionFields = found.Effective.SkippableOptionFields + IncludesProperties = found.Effective.IncludeRecordProperties + UnionEncoding = unionEncodingOf found + AllowsNullFields = found.Effective.AllowNullFields + }) + + /// What FSharp.SystemTextJson reads when it writes a union type. + let unionOptionsOf (unionType : Type) : UnionOptions voption = + converterOptionsOf unionType + |> ValueOption.map (fun found -> + let effective = found.Effective + + { + Encoding = unionEncodingOf found + TagName = effective.UnionTagName + FieldsName = effective.UnionFieldsName + TagNamingPolicy = effective.UnionTagNamingPolicy + FieldNamingPolicy = + match withNull effective.UnionFieldNamingPolicy with + | null -> found.NamingPolicy + | policy -> policy + Common = + found.Common + |> ValueOption.filter (fun common -> obj.ReferenceEquals (common, effective)) + } + ) + + /// + /// Whether the serializer made a contract itself. It chooses the converter by rules that the layout follows: the + /// first one among the options that takes the type, then the one that an attribute names, then one of its own. + /// A resolver of the application can make a contract from any converter instead, also from a converter of + /// FSharp.SystemTextJson that it made with options of its own, and nothing shows how it made that converter. + /// + /// + /// names the resolver + /// that made a contract. The resolver of the serializer names itself, also as the class that an application + /// derives from it to change the contracts it makes, while a contract that an application makes from a + /// converter names none. + /// + let isMadeBySerializer (info : JsonTypeInfo) : bool = + match info.OriginatingResolver with + | :? DefaultJsonTypeInfoResolver -> true + | _ -> false + + /// Who writes the members of a type. + let writerOf = + remembered (fun (documentType : Type) -> + match typeInfoOf documentType with + | ValueSome info when info.Kind = JsonTypeInfoKind.Object -> Writer.Serializer info + | ValueSome info when + isMadeBySerializer info + && isMadeOf typedefof> (info.Converter.GetType ()) + -> + match recordOptionsOf documentType with + | ValueSome recordOptions -> Writer.Record recordOptions + | ValueNone -> Writer.Unknown + | _ -> Writer.Unknown + ) + + /// + /// How a value without a value is written with a contract where it is not left out. The serializer is asked + /// to write one: a null, or the value option or the skippable value that has no value. + /// + /// + /// The serializer writes a null as null itself, unless the converter asks for the null with + /// . Such a converter writes what + /// it likes, and some cannot write a null at all: the converters of FSharp.SystemTextJson for tuples, for maps + /// and for unions without fields ask for the null and fail on it. Only null is described. + /// + let absentWrittenWith (contractOfValue : JsonTypeInfo voption) : OptionalEncoding = + match contractOfValue with + // The serializer has no contract for the type, and it needs one also to write a null of it. + | ValueNone -> OptionalEncoding.NotDescribed + | ValueSome info -> + let absent : objnull = + if info.Type.IsValueType then + Activator.CreateInstance info.Type + else + null + + try + if JsonSerializer.SerializeToElement(absent, info).ValueKind = JsonValueKind.Null then + OptionalEncoding.AlwaysNull + else + OptionalEncoding.NotDescribed + with _ -> + // Whatever a converter raises for the value, no document holds what it would have written. + OptionalEncoding.NotDescribed + + /// + /// Whether a value of that is present is written as the value itself: by a + /// converter of FSharp.SystemTextJson that unwraps it, or by System.Text.Json, which writes an option as its + /// value and a nullable and a reference as themselves. + /// + let isWrittenAsItself (kind : OptionalKind) (valueType : Type) : bool = + match kind with + | OptionalKind.Nullable -> true + | OptionalKind.Never -> false + | OptionalKind.Option + | OptionalKind.ValueOption + | OptionalKind.Skippable -> + match typeInfoOf valueType with + | ValueSome info -> + let converter = info.Converter.GetType () + + isMadeOf typedefof> converter + || isMadeOf typedefof> converter + || isMadeOf typedefof> converter + // System.Text.Json has converters of its own for the two option types, and none for a Skippable. + || (kind <> OptionalKind.Skippable + && converter.Assembly.Equals serializerAssembly) + | ValueNone -> false + + /// + /// The entry that a contract has for a member, with the member that the entry was made of: the member itself, + /// or the override of it that the type of the contract has when the contract lists no other entry for it. What + /// the serializer reads from a member, it reads from the one the entry was made of. + /// + let propertyOf (info : JsonTypeInfo) (memberOfDocument : MemberInfo) : struct (JsonPropertyInfo * MemberInfo) voption = + let entries = seq { + for property in info.Properties do + match property.AttributeProvider with + | :? MemberInfo as own -> struct (property, own) + | _ -> () + } + + entries + |> Seq.tryFind (fun (struct (_, own)) -> isSameMember own memberOfDocument) + |> ValueOption.orElseWith (fun () -> + entries + |> Seq.tryFind (fun (struct (_, own)) -> isOverrideOf memberOfDocument own) + ) + + /// + /// The contract that a member with a converter of its own writes a value of + /// with. The serializer has no such contract, it keeps the converter with the member; options that hold the + /// converter before every other one give it. + /// + /// + /// + /// Those options have the resolver of the serializer and not the one of the caller. The serializer writes the + /// member with its converter whatever contract the resolver of the caller makes for the type, and such a + /// resolver can make that contract without looking at the converters of the options it is asked with. + /// + /// + /// A member can name a factory, which the serializer has make the converter with the options. Such a factory + /// may ask those options for the converter that they have for the type, to add something around it. Asked by + /// options that hold the factory itself, it would be asked without end, so the factory makes the converter + /// with the options of the layout first, and the options that are asked for the contract hold what it made. + /// Nothing is caught here: the serializer has made the converter the same way before it listed the member, + /// and would have refused a member whose converter does not fit its type. + /// + /// + let ownInfoOf (converter : JsonConverter) (valueType : Type) : JsonTypeInfo voption = + let made = + match converter with + | :? JsonConverterFactory as factory -> factory.CreateConverter (valueType, contract) + | converter -> converter + + match made with + // The serializer refuses a member whose factory makes nothing, so no contract lists such a member. + | null -> ValueNone + | made -> + let own = JsonSerializerOptions (contract, TypeInfoResolver = DefaultJsonTypeInfoResolver ()) + own.Converters.Insert (0, made) + ValueSome (own.GetTypeInfo valueType) + + /// + /// Whether System.Text.Json never writes a member of an object: the member has no getter the serializer may + /// call, or it is read-only and the options ignore read-only members. + /// + /// + /// + /// The contract does not show the second case: such a property keeps its getter and gets no rule. The rule is + /// the one of the serializer. A member that has a rule is not left out, because the serializer asks the rule + /// instead: the contract has one for a member that says itself when it is ignored, with a + /// of any condition, and for a member that + /// code gave one. Neither is a collection or a dictionary left out, which the serializer writes also when + /// nothing can assign it. What writes the member decides whether it is one: the serializer, which writes the + /// items, or a converter of the options or of the member, which writes what it likes. + /// + /// + /// One case cannot be told. Code that sets the rule of a member to has set a rule to + /// the serializer, which then writes the read-only member; it remembers that in a field that is not public, + /// and the contract shows the same as for a member that nothing touched. Such a member + /// is taken to be left out. + /// + /// + let isNeverWritten (property : JsonPropertyInfo) (memberOfDocument : MemberInfo) : bool = + let ignoresReadOnly = + match memberOfDocument with + | :? PropertyInfo -> contract.IgnoreReadOnlyProperties + | :? FieldInfo -> contract.IgnoreReadOnlyFields + | _ -> false + + let isReadOnly () = + match property.Set with + | null -> true + | _ -> false + + let isCollection () = + let info = + match property.CustomConverter with + | null -> typeInfoOf property.PropertyType + | converter -> ownInfoOf converter property.PropertyType + + match info with + | ValueSome info -> + info.Kind = JsonTypeInfoKind.Enumerable + || info.Kind = JsonTypeInfoKind.Dictionary + | ValueNone -> false + + match property.Get with + | null -> true + | _ -> + ignoresReadOnly + && isReadOnly () + && not (isCollection ()) + && ( + match property.ShouldSerialize with + | null -> true + | _ -> false + ) + + /// + /// Whether FSharp.SystemTextJson writes a member of a record: its fields, whatever their accessibility, and + /// of its other properties the public ones, when the options or the member say so. It never writes a member + /// that is marked with , whatever the + /// condition of the attribute says. + /// + let isWrittenByRecord (recordOptions : RecordOptions) (memberOfDocument : MemberInfo) : bool = + match memberOfDocument with + | :? PropertyInfo as property when not (isMarked typeof property) -> + let isField = + match property.DeclaringType with + | null -> false + | recordType -> + FSharpType.GetRecordFields (recordType, AnyAccessibility) + |> Array.exists (fun field -> isSameMember field property) + + let isPublic = + match property.GetMethod with + | null -> false + | getter -> getter.IsPublic + + isField + || (isPublic + && (recordOptions.IncludesProperties + || isMarked typeof property)) + | _ -> false + + /// The name of a member, by the rules of who writes its type. + let nameOf (memberOfDocument : DocumentMember) : string voption = + match writerOf memberOfDocument.Holder with + | Writer.Serializer info -> + match propertyOf info memberOfDocument.Member with + | ValueSome (struct (property, _)) when property.IsExtensionData -> ValueNone + | ValueSome (struct (property, own)) when isNeverWritten property own -> declaredNameOf false own + | ValueSome (struct (property, _)) -> ValueSome property.Name + | ValueNone -> ValueNone + | Writer.Record recordOptions -> + let field = memberOfDocument.Member + let declared = declaredNameOf true field + + if isWrittenByRecord recordOptions field then + declared + |> ValueOption.orElseWith (fun () -> + match recordOptions.NamingPolicy with + | null -> ValueSome field.Name + | policy -> ValueSome (policy.ConvertName field.Name) + ) + else + // A member that is never written has the name it declares, when it declares one. + declared + | Writer.Unknown -> ValueNone + + /// + /// How a member of a type that System.Text.Json writes as an object is written without a value. The member + /// decides with its own , and the options + /// decide for a member that has none. + /// + /// The entry of the member in the contract. + /// The member. + /// The kind of its value. + /// How the value is written without one when it is not left out. + let absenceInObject + (property : JsonPropertyInfo) + (memberOfDocument : MemberInfo) + (kind : OptionalKind) + (whenWritten : OptionalEncoding) + : OptionalEncoding = + let condition = + // The attribute of the member itself: an override has none of the declaration it overrides. + match memberOfDocument.GetCustomAttribute false with + | null -> + match property.ShouldSerialize with + // A rule that code has set: it is a function, which says nothing before it is called. + | null -> ValueSome defaultIgnoreCondition + | _ -> ValueNone + | attribute -> ValueSome attribute.Condition + + match condition, kind with + // The serializer never writes the member, so whatever writes the property decides. A member that is + // always ignored is such a member: the serializer keeps no getter for it. + | _ when isNeverWritten property memberOfDocument -> OptionalEncoding.NullOrUndefined + // A rule that code has set chooses between leaving the member out and writing it. + | ValueNone, _ when whenWritten.IsAlwaysNull -> OptionalEncoding.NullOrUndefined + | ValueNone, _ -> OptionalEncoding.NotDescribed + | ValueSome JsonIgnoreCondition.WhenWritingDefault, _ -> OptionalEncoding.AlwaysUndefined + // An option without a value and a nullable without a value are null; a value option and a Skippable + // without a value are structs, which are not null, so they are written, as null. + | ValueSome JsonIgnoreCondition.WhenWritingNull, (OptionalKind.Option | OptionalKind.Nullable) -> + OptionalEncoding.AlwaysUndefined + | ValueSome _, _ -> whenWritten + + /// + /// How a field of a record that FSharp.SystemTextJson writes is written without a value. + /// + /// The options that the record is written with. + /// The kind of the value of the field. + /// The type of the value. + /// How the value is written without one when it is not left out. + let absenceInRecord + (recordOptions : RecordOptions) + (kind : OptionalKind) + (valueType : Type) + (whenWritten : OptionalEncoding) + : OptionalEncoding = + let isLeftOut = + match kind with + | OptionalKind.Skippable -> true + | OptionalKind.Option -> + recordOptions.SkippableOptionFields = SkippableOptionFields.Always + || (recordOptions.SkippableOptionFields = SkippableOptionFields.FromJsonSerializerOptions + && recordOptions.IgnoresNull) + // A value option without a value is not null, so only the setting for every option leaves it out. + | OptionalKind.ValueOption -> recordOptions.SkippableOptionFields = SkippableOptionFields.Always + | OptionalKind.Nullable -> + // A record, a union and a tuple of F# are written also when they are null and null values are + // ignored. A union with a case that is null is the exception, and so is a union that is written + // as the one value it wraps where that value can be null: their null is a value to the library, + // which is left out. + recordOptions.IgnoresNull + && (isNoTypeOfFSharp valueType + || hasNullValue recordOptions valueType) + | OptionalKind.Never -> false + + if isLeftOut then + OptionalEncoding.AlwaysUndefined + else + whenWritten + + /// How a value is written without one, by the rules of who writes the type of its member. + let encodingOf (struct (memberOfDocument : DocumentMember voption, valueType : Type)) : OptionalEncoding = + let kind = optionalKindOf valueType + + if not (isWrittenAsItself kind valueType) then + OptionalEncoding.NotDescribed + else + // What is written for the value where it is not left out, by the converter of the type or by the one + // that a member names. + let whenWritten = absentWrittenWith (typeInfoOf valueType) + + match memberOfDocument with + | ValueNone -> whenWritten + | ValueSome memberOfDocument -> + match writerOf memberOfDocument.Holder with + | Writer.Serializer info -> + match propertyOf info memberOfDocument.Member with + // The entries of the extension data are properties of the document itself, and nothing is + // written for extension data that is null: no property of its name is null or missing. + | ValueSome (struct (property, _)) when property.IsExtensionData -> OptionalEncoding.NotDescribed + | ValueSome (struct (property, own)) -> + match property.CustomConverter with + | null -> absenceInObject property own kind whenWritten + // The serializer leaves a null out, or writes it, before it asks the converter of the + // member, unless that converter asks for the null: what it writes then is asked of the + // serializer. So a reference or a nullable of such a member is described as any other. An + // option, a value option or a skippable value is not: the converter writes all of it, and + // nothing shows what it writes for one with a value. + | converter when kind = OptionalKind.Nullable -> + absenceInObject property own kind (absentWrittenWith (ownInfoOf converter property.PropertyType)) + | _ -> OptionalEncoding.NotDescribed + | ValueNone -> OptionalEncoding.NotDescribed + | Writer.Record recordOptions -> + // Whatever writes the property of a member that FSharp.SystemTextJson never writes decides. + if isWrittenByRecord recordOptions memberOfDocument.Member then + absenceInRecord recordOptions kind valueType whenWritten + else + OptionalEncoding.NullOrUndefined + | Writer.Unknown -> OptionalEncoding.NotDescribed + + /// + /// The contract that the serializer writes a value with: the one of its type, or the one of the converter + /// that the member of the value names. No contract when the layout does not know what writes the value. The + /// value is asked about by the member that holds it, when a member does, and by its type. + /// + /// + /// Whether the contract of a converter that the member names is given. Without it such a member has no + /// contract: the question is one that the class of a converter does not answer. + /// + let valueInfoWith + (followsConverter : bool) + (struct (memberOfDocument : DocumentMember voption, valueType : Type)) + : JsonTypeInfo voption = + match memberOfDocument with + | ValueNone -> typeInfoOf valueType + | ValueSome memberOfDocument -> + match writerOf memberOfDocument.Holder with + | Writer.Serializer info -> + match propertyOf info memberOfDocument.Member with + // The entries of the extension data are properties of the document itself, so no property holds + // the dictionary. + | ValueSome (struct (property, _)) when property.IsExtensionData -> ValueNone + // Whatever writes a property that the serializer never writes decides how. + | ValueSome (struct (property, own)) when isNeverWritten property own -> ValueNone + | ValueSome (struct (property, _)) -> + let memberType = property.PropertyType + + // The converter of a member writes the whole value of the member, also the nullable that + // the member is. What it writes for a part of the value, such as the value of an option, + // nothing shows. + let isWholeValue () = + Type.(=) (valueType, memberType) + || ( + match Nullable.GetUnderlyingType memberType with + | null -> false + | underlying -> Type.(=) (valueType, underlying) + ) + + match property.CustomConverter with + | null -> typeInfoOf valueType + | converter when followsConverter && isWholeValue () -> ownInfoOf converter memberType + | _ -> ValueNone + | ValueNone -> ValueNone + | Writer.Record recordOptions -> + // FSharp.SystemTextJson does not read the converter that a member of a record names. A member + // that it does not write is described by nothing: whatever writes its property decides how. + if isWrittenByRecord recordOptions memberOfDocument.Member then + typeInfoOf valueType + else + ValueNone + | Writer.Unknown -> ValueNone + + /// The contract that the serializer writes a value with, also the one of a converter that its member names. + let valueInfoOf (question : struct (DocumentMember voption * Type)) : JsonTypeInfo voption = valueInfoWith true question + + /// + /// How an enumeration is written. The serializer is asked to write its values, because nothing else tells: + /// System.Text.Json has one converter for numbers and for names, which keeps to itself what it writes. + /// + /// + /// Every value that has a name is written, and all of them have to come out as one kind of JSON value: a + /// converter of the application can write one value as its name and another as a number, and such an + /// enumeration is written in no one way. + /// + let enumEncodingOf (struct (_, valueType : Type) as question) : EnumEncoding = + let enumType = + match Nullable.GetUnderlyingType valueType with + | null -> valueType + | underlying -> underlying + + if not enumType.IsEnum then + EnumEncoding.NotDescribed + else + match valueInfoOf question with + | ValueNone -> EnumEncoding.NotDescribed + | ValueSome info -> + // The values with a name: a converter of names writes a value without one as its number. An + // enumeration that declares no value has only such a value to write. + let values = Enum.GetValues enumType + + let named = + if values.Length = 0 then + Seq.singleton (Enum.ToObject (enumType, 0)) + else + Seq.cast values + + try + let kinds = + named + |> Seq.map (fun value -> JsonSerializer.SerializeToElement(value, info).ValueKind) + |> Seq.distinct + |> Seq.toArray + + match kinds with + | [| JsonValueKind.Number |] -> EnumEncoding.Number + | [| JsonValueKind.String |] -> EnumEncoding.String + | _ -> EnumEncoding.NotDescribed + with + | :? JsonException + | :? NotSupportedException -> + // The converter refuses a value, as the one of names does when it was made to. These are the + // two exceptions that the serializer has for a value that a converter does not write. + EnumEncoding.NotDescribed + + /// How a tuple is written: System.Text.Json writes it as an object, FSharp.SystemTextJson as an array. + let tupleEncodingOf (struct (_, tupleType : Type) as question) : TupleEncoding = + if not (FSharpType.IsTuple tupleType) then + TupleEncoding.NotDescribed + else + match valueInfoOf question with + | ValueSome info when info.Kind = JsonTypeInfoKind.Object -> TupleEncoding.Object + | ValueSome info when isTupleConverter (info.Converter.GetType ()) -> TupleEncoding.Array + | _ -> TupleEncoding.NotDescribed + + /// + /// How a collection is written: as an array when the contract says that the serializer writes its items, or + /// when a converter of FSharp.SystemTextJson for lists or sets writes it. + /// + let collectionEncodingOf (question : struct (DocumentMember voption * Type)) : CollectionEncoding = + match valueInfoOf question with + // The contract of a type whose items the serializer writes names the type of an item. + | ValueSome info when info.Kind = JsonTypeInfoKind.Enumerable -> CollectionEncoding.Array (nonNull info.ElementType) + | ValueSome info -> + let converter = info.Converter.GetType () + + if + isMadeOf typedefof> converter + || isMadeOf typedefof> converter + then + CollectionEncoding.Array (converter.GetGenericArguments()[0]) + else + CollectionEncoding.NotDescribed + | ValueNone -> CollectionEncoding.NotDescribed + + /// + /// How a map is written: as an object when the contract says that the serializer writes it as a dictionary, and + /// as the converter of FSharp.SystemTextJson that writes it does. + /// + let mapEncodingOf (question : struct (DocumentMember voption * Type)) : MapEncoding = + match valueInfoOf question with + // The contract of a dictionary names the types of a key and of a value. + | ValueSome info when info.Kind = JsonTypeInfoKind.Dictionary -> + MapEncoding.Object (nonNull info.KeyType, nonNull info.ElementType) + | ValueSome info -> + let converter = info.Converter.GetType () + + if isMadeOf typedefof> converter then + let arguments = converter.GetGenericArguments () + MapEncoding.Object (arguments[0], arguments[1]) + elif isMadeOf typedefof> converter then + let arguments = converter.GetGenericArguments () + MapEncoding.ArrayOfPairs (arguments[0], arguments[1]) + else + MapEncoding.NotDescribed + | ValueNone -> MapEncoding.NotDescribed + + /// + /// How FSharp.SystemTextJson writes a case of a union with the options that it has for the union. The rules + /// are read from the source of the library and compared with what it writes. + /// + /// + /// + /// A value that is null is written as null before anything else, and a case without fields as its tag alone + /// when such tags are unwrapped. Then the encoding decides where the tag is: in a property next to the + /// property of the fields, as the name of the property of the fields, as the first item or a property among + /// the fields, or nowhere. + /// + /// + /// The fields are an array of their values or an object with a property for each. A case with one field + /// writes that value in place of the fields where the encoding unwraps such cases, which the internal tag and + /// the encoding without tags do not do. A case whose one field is a record writes the members of the record + /// in place of the fields where the encoding unwraps records. The library writes such a record with the + /// options of the union, so it is described only when those are the common ones and the record by itself is + /// written by the library as well: then the object is the record as it is written anywhere, and + /// + /// names its members. Only next to an internal tag is the object more than the record. + /// + /// + let writtenCaseOf (options : UnionOptions) (case : UnionCaseInfo) : UnionCaseEncoding = + let encoding = options.Encoding + let fields = case.GetFields () + let tag = unionTagOf options.TagNamingPolicy case + let hasNamedFields = encoding.HasFlag JsonUnionEncoding.NamedFields + + // The case that a union marked to do so represents by null. The compiler lets a union be marked so only + // when it has a case with fields as well (FS1196), so the converter of the unions without fields, which + // writes a tag for every case, never writes such a union. + let isNullCase = + fields.Length = 0 + && ( + match FSharpValue.MakeUnion (case, [||], AnyAccessibility) with + | null -> true + | _ -> false + ) + + // The flag that unwraps records holds the one that names the fields. + let unwrapsRecord = + fields.Length = 1 + && FSharpType.IsRecord (fields[0].PropertyType, AnyAccessibility) + && encoding.HasFlag JsonUnionEncoding.UnwrapRecordCases + + let unwrapsField = + not unwrapsRecord + && fields.Length = 1 + && encoding.HasFlag JsonUnionEncoding.UnwrapSingleFieldCases + + // Whether the record that the case unwraps is written as the layout describes a record of its type. The + // converter of the union writes the members of the record with its own options of the serializer and + // with the options of FSharp.SystemTextJson that it has, or with the ones that it finds for the record. + // The record by itself is written the same way only by a converter that the same converter among the + // options makes. One that an attribute of the record makes by itself has no naming policy, and another + // converter among the options has other options. + let isRecordDescribed () = + let recordType = fields[0].PropertyType + + match options.Common, writerOf recordType, converterOptionsOf recordType with + | ValueSome common, Writer.Record _, ValueSome ofRecord -> + ofRecord.Common + |> ValueOption.exists (fun forRecords -> obj.ReferenceEquals (forRecords, common)) + | _ -> false + + let step (container : ImmutableArray) (next : JsonStep) : ImmutableArray = container.Add next + + // The fields as the properties of the object at the end of the steps, which holds the tag as well or not. + let asProperties (container : ImmutableArray) (holdsTag : bool) : ImmutableArray voption = + if unwrapsRecord then + if not (isRecordDescribed ()) then + ValueNone + elif holdsTag then + ValueSome (ImmutableArray.Create (UnionFieldPlace.Members container)) + else + // Without a tag in it the object is the record as it is written anywhere. + ValueSome (ImmutableArray.Create (UnionFieldPlace.Value container)) + else + unionFieldNamesOf options case + |> Seq.map (fun name -> UnionFieldPlace.Value (step container (JsonStep.Property name))) + |> ImmutableArray.CreateRange + |> ValueSome + + // The fields as the items of the array at the end of the steps, from the index that is given. + let asItems (container : ImmutableArray) (first : int) : ImmutableArray voption = + fields + |> Seq.mapi (fun index _ -> UnionFieldPlace.Value (step container (JsonStep.Item (first + index)))) + |> ImmutableArray.CreateRange + |> ValueSome + + // The fields as what the property at the end of the steps holds. + let asFields (container : ImmutableArray) : ImmutableArray voption = + if unwrapsField then + ValueSome (ImmutableArray.Create (UnionFieldPlace.Value container)) + elif hasNamedFields then + asProperties container false + else + asItems container 0 + + let written (mark : UnionCaseMark) (places : ImmutableArray voption) : UnionCaseEncoding = + match places with + | ValueSome places -> UnionCaseEncoding.Written (mark, places) + | ValueNone -> UnionCaseEncoding.NotDescribed + + let root = ImmutableArray.Empty + + if isNullCase then + UnionCaseEncoding.Written (UnionCaseMark.Null, ImmutableArray.Empty) + elif + fields.Length = 0 + && encoding.HasFlag JsonUnionEncoding.UnwrapFieldlessTags + then + UnionCaseEncoding.Written (UnionCaseMark.Tag (root, tag), ImmutableArray.Empty) + else + match int encoding &&& UnionFormatBits with + // No bit says where the tag is: next to the fields. + | 0 -> + written + (UnionCaseMark.Tag (ImmutableArray.Create (JsonStep.Property options.TagName), tag)) + (asFields (ImmutableArray.Create (JsonStep.Property options.FieldsName))) + | bits when bits = int JsonUnionEncoding.ExternalTag -> + let name = propertyNameOf tag + written (UnionCaseMark.Property name) (asFields (ImmutableArray.Create (JsonStep.Property name))) + | bits when bits = int JsonUnionEncoding.InternalTag -> + if hasNamedFields then + written + (UnionCaseMark.Tag (ImmutableArray.Create (JsonStep.Property options.TagName), tag)) + (asProperties root true) + else + written (UnionCaseMark.Tag (ImmutableArray.Create (JsonStep.Item 0), tag)) (asItems root 1) + | UntaggedBit -> written UnionCaseMark.Unmarked (asProperties root false) + // Two places for the tag at once: the library fails to write such a union. + | _ -> UnionCaseEncoding.NotDescribed + + /// + /// Whether a case is written as an object with two properties of the name of the tag. FSharp.SystemTextJson + /// writes one when the options give the property of the fields the name of the tag, and when a field with a + /// name, or a member of the record whose members the case writes, has that name next to an internal tag. + /// + /// + /// The place of the tag is then the place of a field or on the way to one. A query reads one property of a + /// name, and nothing says which of the two it is: the tag cannot be told, and neither can the field. + /// + let writesTagTwice (options : UnionOptions) (case : UnionCaseInfo) : bool = + match writtenCaseOf options case with + | UnionCaseEncoding.Written (UnionCaseMark.Tag (tagPath, _), places) -> + places + |> Seq.exists (fun place -> + match place with + | UnionFieldPlace.Value path -> beginsWith tagPath path + | UnionFieldPlace.Members container -> + // The members of the record are properties of the object that holds the tag. + let fields = case.GetFields () + let recordType = fields[0].PropertyType + + FSharpType.GetRecordFields (recordType, AnyAccessibility) + |> Array.exists (fun field -> + nameOf { Holder = recordType; Member = field } + |> ValueOption.exists (fun name -> beginsWith tagPath (container.Add (JsonStep.Property name))) + ) + ) + | _ -> false + + /// + /// How a case of a union is written. The contract of the union names the converter, and the converters of + /// FSharp.SystemTextJson for unions are told by their classes; the options that the union is written with + /// say the rest. + /// + /// + /// No case of a union is described when one of its cases is written with the name of the tag twice: the + /// second property of such a document can hold what is the tag of another case. + /// + let unionCaseEncodingOf (struct (memberOfDocument : DocumentMember voption, case : UnionCaseInfo)) : UnionCaseEncoding = + let unionType = case.DeclaringType + + match valueInfoWith false (struct (memberOfDocument, unionType)) with + | ValueSome info -> + let converter = info.Converter.GetType () + + if isMadeOf typedefof> converter then + // The class says all of it: the one field of the one case is written in place of the union. + UnionCaseEncoding.Written ( + UnionCaseMark.Unmarked, + ImmutableArray.Create (UnionFieldPlace.Value ImmutableArray.Empty) + ) + elif + isMadeBySerializer info + && (isMadeOf typedefof> converter + || isMadeOf typedefof> converter) + then + match unionOptionsOf unionType with + | ValueSome options when + FSharpType.GetUnionCases (unionType, AnyAccessibility) + |> Array.exists (writesTagTwice options) + -> + UnionCaseEncoding.NotDescribed + | ValueSome options -> writtenCaseOf options case + | ValueNone -> UnionCaseEncoding.NotDescribed + else + UnionCaseEncoding.NotDescribed + | ValueNone -> UnionCaseEncoding.NotDescribed + + let rememberedName = remembered nameOf + let rememberedEncoding = remembered encodingOf + let rememberedEnumEncoding = remembered enumEncodingOf + let rememberedTupleEncoding = remembered tupleEncodingOf + let rememberedCollectionEncoding = remembered collectionEncodingOf + let rememberedMapEncoding = remembered mapEncodingOf + let rememberedUnionCaseEncoding = remembered unionCaseEncodingOf + + interface IJsonLayout with + + /// + member _.MemberName (memberOfDocument : DocumentMember) : string voption = rememberedName memberOfDocument + + /// + member _.OptionalEncoding (memberOfDocument : DocumentMember voption, valueType : Type) : OptionalEncoding = + rememberedEncoding (struct (memberOfDocument, valueType)) + + /// + member _.EnumEncoding (memberOfDocument : DocumentMember voption, enumType : Type) : EnumEncoding = + rememberedEnumEncoding (struct (memberOfDocument, enumType)) + + /// + member _.TupleEncoding (memberOfDocument : DocumentMember voption, tupleType : Type) : TupleEncoding = + rememberedTupleEncoding (struct (memberOfDocument, tupleType)) + + /// + member _.CollectionEncoding (memberOfDocument : DocumentMember voption, collectionType : Type) : CollectionEncoding = + rememberedCollectionEncoding (struct (memberOfDocument, collectionType)) + + /// + member _.MapEncoding (memberOfDocument : DocumentMember voption, mapType : Type) : MapEncoding = + rememberedMapEncoding (struct (memberOfDocument, mapType)) + + /// + member _.UnionCaseEncoding (memberOfDocument : DocumentMember voption, case : UnionCaseInfo) : UnionCaseEncoding = + rememberedUnionCaseEncoding (struct (memberOfDocument, case)) + + /// + /// The layout of the documents that System.Text.Json writes with , with or without the + /// converter of FSharp.SystemTextJson among them. Pass the options that the Cosmos DB client serializes with. + /// + /// + /// + /// The layout reads when it is made and keeps a copy, so a change of them afterwards + /// does not reach it. What it finds out about a member is kept for as long as the layout is. + /// + /// + /// The resolver of the contracts, , is not + /// copied: it can be any object, so the layout asks the one that the serializer asks. A change of that resolver + /// before the layout is asked for the first time reaches the layout as it reaches the serializer. From that + /// question on a refuses a + /// change of its , + /// as it does after the first document is written, so the layout and the serializer cannot come to disagree + /// unnoticed. A resolver of the application has to give one answer for a type every time it is asked, which the + /// serializer needs as well. + /// + /// + /// It describes the members of the types that System.Text.Json writes as objects and of the records that + /// FSharp.SystemTextJson writes. A member of a type that another converter writes has no name here, and neither + /// has a member of a record whose contract a resolver of the application made from a converter: nothing shows how + /// that converter was made. + /// + /// + /// An enumeration, a tuple, a collection and a map are described as System.Text.Json and FSharp.SystemTextJson + /// write them, by the converter that the options have for the type or by the one that a member names for itself. + /// What a converter of the application writes is not described, except for an enumeration: the layout has the + /// serializer write every value of it that has a name, and describes the enumeration when numbers come out for + /// all of them or strings for all of them. An enumeration whose values come out in both ways is not described, + /// and neither is one whose converter refuses a value. + /// + /// + /// The options of the serializer. + /// The layout. + let ofSerializerOptions (options : JsonSerializerOptions) : IJsonLayout = SerializerLayout options 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..d712f54b --- /dev/null +++ b/src/Cosmos.Quotations/Parameterizer.fs @@ -0,0 +1,941 @@ +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 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. +/// 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 + | TypeCode.Single + | TypeCode.Double -> true + | _ -> 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 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..6b3688ae --- /dev/null +++ b/src/Cosmos.Quotations/Query.fs @@ -0,0 +1,52 @@ +/// +/// 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 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, 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..865ae14b --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/FSharp.Azure.Cosmos.Quotations.Tests.fsproj @@ -0,0 +1,56 @@ + + + + + net10.0 + $(AssemblyBaseName).Quotations.Tests + + Exe + true + + + $(OtherFlags) --quotations-debug+ + + + + + PreserveNewest + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/Cosmos.Quotations.Tests/JsonLayoutTests.fs b/tests/Cosmos.Quotations.Tests/JsonLayoutTests.fs new file mode 100644 index 00000000..5a7da988 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/JsonLayoutTests.fs @@ -0,0 +1,1978 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections +open System.Collections.Generic +open System.Collections.Immutable +open System.Reflection +open System.Reflection.Emit +open System.Text.Json +open System.Text.Json.Serialization +open System.Text.Json.Serialization.Metadata +open System.Threading +open System.Threading.Tasks +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Quotations +open FSharp.Quotations.Patterns +open FSharp.Reflection + +open FSharp.Azure.Cosmos +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// A way to set up the serializer, as a function that makes its options anew: a test may change what it gets. +[] +type SerializerProfile = { + /// What is special about the options; the name of a test result holds it. + Name : string + /// Makes the options. + Create : unit -> JsonSerializerOptions + /// Whether the options hold the converter of FSharp.SystemTextJson, without which no skippable value is written. + HasFSharpConverter : bool +} + +/// The ways to set up the serializer that the tests of the layout write the model with. +module SerializerProfiles = + + /// Options of System.Text.Json alone. + let private plain (name : string) (configure : JsonSerializerOptions -> unit) : SerializerProfile = { + Name = name + Create = + fun () -> + let options = JsonSerializerOptions () + configure options + options + HasFSharpConverter = false + } + + /// Options with the converter of FSharp.SystemTextJson. + let private fsharp + (name : string) + (configureConverter : JsonFSharpOptions -> JsonFSharpOptions) + (configure : JsonSerializerOptions -> unit) + : SerializerProfile = { + Name = name + Create = + fun () -> + let options = (configureConverter (JsonFSharpOptions.Default ())).ToJsonSerializerOptions() + configure options + options + HasFSharpConverter = true + } + + // JsonSerializerOptions.IgnoreNullValues is obsolete, and the serializers still follow it: two profiles are about it. + #nowarn "44" + + /// Sets the setting of old that ignores null. + let private ignoreNullValues (options : JsonSerializerOptions) : unit = options.IgnoreNullValues <- true + + #warnon "44" + + /// System.Text.Json alone, as it is made. + let systemTextJson = plain "System.Text.Json with its defaults" ignore + + /// FSharp.SystemTextJson as it is made. + let fsharpSystemTextJson = fsharp "FSharp.SystemTextJson with its defaults" id ignore + + /// FSharp.SystemTextJson writing an option as a union with the name of its case. + let withoutUnwrappedOptions = + fsharp + "FSharp.SystemTextJson that does not unwrap options" + _.WithUnionEncoding( + JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapSingleCaseUnions + ) + ignore + + /// System.Text.Json writing an enumeration as the name of its value. + let enumerationsByName = + plain + "System.Text.Json that writes enumerations by name" + (fun options -> options.Converters.Add (JsonStringEnumConverter ())) + + /// System.Text.Json leaving out the properties that are only read. + let ignoringReadOnlyProperties = + plain "System.Text.Json that ignores read-only properties" (fun options -> options.IgnoreReadOnlyProperties <- true) + + /// Every profile. + let all = + seq { + systemTextJson + plain + "System.Text.Json with camel case names" + (fun options -> options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase) + plain + "System.Text.Json with snake case names that ignores null" + (fun options -> + options.PropertyNamingPolicy <- JsonNamingPolicy.SnakeCaseLower + options.DefaultIgnoreCondition <- JsonIgnoreCondition.WhenWritingNull + ) + plain "System.Text.Json that ignores null with the setting of old" ignoreNullValues + plain + "System.Text.Json with a converter that writes null itself" + (fun options -> options.Converters.Add (StoredNullAsDashConverter ())) + plain + "System.Text.Json that ignores default values" + (fun options -> options.DefaultIgnoreCondition <- JsonIgnoreCondition.WhenWritingDefault) + plain "System.Text.Json that includes fields" (fun options -> options.IncludeFields <- true) + ignoringReadOnlyProperties + plain + "System.Text.Json that includes fields and ignores read-only ones" + (fun options -> + options.IncludeFields <- true + options.IgnoreReadOnlyFields <- true + ) + enumerationsByName + + fsharpSystemTextJson + fsharp + "FSharp.SystemTextJson with camel case names that ignores null" + id + (fun options -> + options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase + options.DefaultIgnoreCondition <- JsonIgnoreCondition.WhenWritingNull + ) + fsharp "FSharp.SystemTextJson that ignores null with the setting of old" id ignoreNullValues + fsharp + "FSharp.SystemTextJson with a converter that writes null itself" + id + (fun options -> options.Converters.Insert (0, StoredNullAsDashConverter ())) + fsharp + "FSharp.SystemTextJson that ignores default values" + id + (fun options -> options.DefaultIgnoreCondition <- JsonIgnoreCondition.WhenWritingDefault) + fsharp + "FSharp.SystemTextJson that always skips an option without a value" + _.WithSkippableOptionFields(SkippableOptionFields.Always) + ignore + fsharp + "FSharp.SystemTextJson that never skips an option and ignores null" + _.WithSkippableOptionFields(SkippableOptionFields.Never) + (fun options -> options.DefaultIgnoreCondition <- JsonIgnoreCondition.WhenWritingNull) + withoutUnwrappedOptions + fsharp + "FSharp.SystemTextJson without its converters of options" + _.WithTypes(JsonFSharpTypes.All &&& ~~~JsonFSharpTypes.OptionalTypes) + ignore + fsharp + "FSharp.SystemTextJson without its converter of records" + _.WithTypes(JsonFSharpTypes.All &&& ~~~JsonFSharpTypes.Records) + (fun options -> options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase) + fsharp "FSharp.SystemTextJson that includes the properties of records" _.WithIncludeRecordProperties() ignore + fsharp + "FSharp.SystemTextJson with other options for one record type" + (fun converterOptions -> + converterOptions + .WithSkippableOptionFields(SkippableOptionFields.Always) + .WithOverrides(fun common -> + let overrides = Dictionary() + overrides.Add (typeof, common.WithSkippableOptionFields SkippableOptionFields.Never) + // For every type that is made of the generic record. + overrides.Add ( + typedefof>, + common.WithSkippableOptionFields SkippableOptionFields.Never + ) + overrides :> IDictionary + ) + ) + ignore + fsharp "FSharp.SystemTextJson that lets an attribute give the options of a type" _.WithAllowOverride() ignore + fsharp + "FSharp.SystemTextJson that ignores read-only properties" + id + (fun options -> options.IgnoreReadOnlyProperties <- true) + fsharp + "FSharp.SystemTextJson that writes enumerations by name" + id + (fun options -> options.Converters.Add (JsonStringEnumConverter ())) + fsharp "FSharp.SystemTextJson that writes every map as an object" _.WithMapFormat(MapFormat.Object) ignore + fsharp + "FSharp.SystemTextJson that writes every map as an array of pairs" + _.WithMapFormat(MapFormat.ArrayOfPairs) + ignore + fsharp + "FSharp.SystemTextJson without its converters of tuples" + _.WithTypes(JsonFSharpTypes.All &&& ~~~JsonFSharpTypes.Tuples) + ignore + fsharp + "FSharp.SystemTextJson without its converters of lists, sets and maps" + _.WithTypes( + JsonFSharpTypes.All + &&& ~~~JsonFSharpTypes.Lists + &&& ~~~JsonFSharpTypes.Sets + &&& ~~~JsonFSharpTypes.Maps + ) + ignore + { + Name = "FSharp.SystemTextJson with one converter for unions and another one for the other types" + Create = + fun () -> + let options = JsonSerializerOptions () + + // The first converter takes no record, so the second one writes the records, with its options. + options.Converters.Add ( + JsonFSharpConverter (JsonFSharpOptions.Default().WithTypes JsonFSharpTypes.Unions) + ) + + options.Converters.Add ( + JsonFSharpConverter ( + JsonFSharpOptions.Default().WithSkippableOptionFields SkippableOptionFields.Always + ) + ) + + options + HasFSharpConverter = true + } + fsharp + "FSharp.SystemTextJson with internal tags, options that are always skipped, snake case names and enumerations by name" + (fun _ -> + JsonFSharpOptions( + JsonUnionEncoding.InternalTag + ||| JsonUnionEncoding.AllowUnorderedTag + ||| JsonUnionEncoding.NamedFields + ||| JsonUnionEncoding.UnwrapSingleCaseUnions + ||| JsonUnionEncoding.UnwrapRecordCases + ||| JsonUnionEncoding.UnwrapOption + ||| JsonUnionEncoding.UnwrapFieldlessTags, + unionTagName = "$type" + ) + .WithSkippableOptionFields(SkippableOptionFields.Always, true) + .WithMapFormat(MapFormat.Object) + ) + (fun options -> + options.PropertyNamingPolicy <- JsonNamingPolicy.SnakeCaseLower + options.Converters.Add (JsonStringEnumConverter ()) + ) + } + |> ImmutableArray.CreateRange + + /// FSharp.SystemTextJson with one of its encodings of unions. + let private encoded (way : string) (encoding : JsonUnionEncoding) : SerializerProfile = + fsharp $"FSharp.SystemTextJson that writes a union %s{way}" _.WithUnionEncoding(encoding) ignore + + /// + /// The ways to set FSharp.SystemTextJson up that write a union differently: every place for the tag with every + /// way to write the fields, and what else the library reads when it writes a union. The tests of unions write + /// their model with these and with . + /// + let unions = + seq { + encoded "with the tag next to the fields" JsonUnionEncoding.AdjacentTag + encoded + "with the tag next to the fields, which have names" + (JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.NamedFields) + encoded + "with the tag next to the fields, and one field in place of the fields" + (JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapSingleFieldCases) + encoded + "with the tag next to the fields, and a case without fields as its tag" + (JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapFieldlessTags) + encoded + "with the tag next to the fields, and the members of a record in place of the fields" + (JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapRecordCases) + encoded + "with the tag next to the fields, which have the names of their types" + (JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.NamedFields + ||| JsonUnionEncoding.UnionFieldNamesFromTypes) + encoded "with the tag as the name of the fields" JsonUnionEncoding.ExternalTag + encoded + "with the tag as the name of the fields, which have names" + (JsonUnionEncoding.ExternalTag + ||| JsonUnionEncoding.NamedFields) + encoded + "with the tag as the name of the fields, and one field in place of the fields" + (JsonUnionEncoding.ExternalTag + ||| JsonUnionEncoding.UnwrapSingleFieldCases) + encoded + "with the tag as the name of the fields, and a case without fields as its tag" + (JsonUnionEncoding.ExternalTag + ||| JsonUnionEncoding.UnwrapFieldlessTags) + encoded + "with the tag as the name of the fields, and the members of a record in place of the fields" + (JsonUnionEncoding.ExternalTag + ||| JsonUnionEncoding.UnwrapRecordCases) + encoded "with the tag before the fields" JsonUnionEncoding.InternalTag + encoded + "with the tag among the fields, which have names" + (JsonUnionEncoding.InternalTag + ||| JsonUnionEncoding.NamedFields) + encoded + "with the tag among the members of a record" + (JsonUnionEncoding.InternalTag + ||| JsonUnionEncoding.UnwrapRecordCases) + encoded "without a tag" JsonUnionEncoding.Untagged + encoded + "without a tag, and the members of a record in place of the fields" + (JsonUnionEncoding.Untagged + ||| JsonUnionEncoding.UnwrapRecordCases) + encoded "as Thoth does" JsonUnionEncoding.ThothLike + encoded "as FSharpLu does" JsonUnionEncoding.FSharpLuLike + fsharp + "FSharp.SystemTextJson with names of its own for the tag and the fields of a union" + _.WithUnionTagName("kind").WithUnionFieldsName("data").WithUnionNamedFields() + ignore + fsharp + "FSharp.SystemTextJson with a naming policy for the tags of a union" + _.WithUnionTagNamingPolicy(JsonNamingPolicy.SnakeCaseUpper).WithUnionUnwrapFieldlessTags() + ignore + fsharp + "FSharp.SystemTextJson with a naming policy for the tags of a union that are names of properties" + _.WithUnionExternalTag().WithUnionTagNamingPolicy(JsonNamingPolicy.CamelCase) + ignore + fsharp + "FSharp.SystemTextJson with a naming policy for the fields of a union" + _.WithUnionNamedFields().WithUnionFieldNamingPolicy(JsonNamingPolicy.SnakeCaseUpper) + (fun options -> options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase) + fsharp + "FSharp.SystemTextJson with named fields of a union and camel case names" + _.WithUnionNamedFields() + (fun options -> options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase) + fsharp + "FSharp.SystemTextJson with other options for some union types" + (fun converterOptions -> + converterOptions.WithOverrides (fun common -> + let overrides = Dictionary() + + overrides.Add ( + typeof, + common.WithUnionInternalTag().WithUnionNamedFields().WithUnionTagName "shape" + ) + + // For every type that is made of the generic union, but for the one that has options itself. + overrides.Add (typedefof>, common.WithUnionExternalTag ()) + overrides.Add (typeof>, common.WithUnionUntagged ()) + overrides :> IDictionary + ) + ) + ignore + fsharp + "FSharp.SystemTextJson with options for a union type that inherit the encoding" + (fun converterOptions -> + converterOptions + .WithUnionExternalTag() + .WithOverrides(fun _ -> + let overrides = Dictionary() + + // The options say that they inherit the encoding, so the tag is where the common options + // have it, and the name that they give the tag is not used. + overrides.Add ( + typeof, + JsonFSharpOptions.InheritUnionEncoding().WithUnionTagName "shape" + ) + + overrides :> IDictionary + ) + ) + ignore + fsharp + "FSharp.SystemTextJson that lets an attribute give the options of a type and has another encoding of unions" + _.WithAllowOverride().WithUnionInternalTag().WithUnionNamedFields() + ignore + fsharp + "FSharp.SystemTextJson without its converters of unions" + _.WithTypes(JsonFSharpTypes.All &&& ~~~JsonFSharpTypes.Unions) + ignore + } + |> ImmutableArray.CreateRange + +/// +/// of +/// : +/// what the layout says about a member is what the serializer writes for it. The serializer is the oracle: every type +/// of the model is written with every way to set the serializer up, and the document is searched for each member. +/// +[] +type JsonLayoutTests () = + + /// + /// The text or the number that a value comes down to when the options, value options and skippable values around + /// it are taken off; no value for a value that is absent at any level, and for a value of another kind. + /// + static let rec scalarOf (value : objnull) : objnull voption = + match value with + | null -> ValueNone + | :? string + | :? int -> ValueSome value + // A collection of one item is found by that item. A list of F# is a union, so this comes first. + | :? IEnumerable as items when (items |> Seq.cast |> Seq.truncate 2 |> Seq.length) = 1 -> + items |> Seq.cast |> Seq.head |> scalarOf + | value -> + let valueType = value.GetType () + + // A union is found by what the one field of its case holds: an option, a value option and a skippable value + // are such unions. + if FSharpType.IsUnion valueType then + match FSharpValue.GetUnionFields (value, valueType) with + | _, [| inner |] -> scalarOf inner + | _ -> ValueNone + elif FSharpType.IsRecord valueType then + // A record is found by what its first field holds. + let fields = FSharpValue.GetRecordFields value + scalarOf fields[0] + else + ValueNone + + /// Whether a JSON value is a text or a number, or holds it somewhere inside. + static let rec holds (scalar : objnull) (json : JsonElement) : bool = + match json.ValueKind, scalar with + | JsonValueKind.String, (:? string as text) -> json.GetString () = text + | JsonValueKind.Number, (:? int as number) -> json.GetInt32 () = number + | JsonValueKind.Object, _ -> + json.EnumerateObject () + |> Seq.exists (fun property -> holds scalar property.Value) + | JsonValueKind.Array, _ -> json.EnumerateArray () |> Seq.exists (holds scalar) + | _ -> false + + /// The name of the property of a document that holds a text or a number. + static let propertyHolding (scalar : objnull) (document : JsonElement) : string voption = + document.EnumerateObject () + |> Seq.tryFind (fun property -> holds scalar property.Value) + |> ValueOption.map _.Name + + /// + /// Everything the layout says about the members of a sample that the documents of the sample do not confirm; empty + /// when the layout is right. + /// + static let disagreements (profile : SerializerProfile) (sample : StoredSample) : string array = + let options = profile.Create () + let layout = JsonLayout.ofSerializerOptions options + let documentType = sample.Present.GetType () + let present = JsonSerializer.SerializeToElement (sample.Present, documentType, options) + let absent = JsonSerializer.SerializeToElement (sample.Absent, documentType, options) + + let scalars = + ModelMembers.ofType documentType + |> Seq.map (fun dataMember -> struct (dataMember, scalarOf (ModelMembers.valueOf sample.Present dataMember))) + |> Seq.toArray + + // A member can be found in the document only by a value that no other member holds. + let isUnique (scalar : objnull) = + let holders = + scalars + |> Seq.filter (fun (struct (_, other)) -> other = ValueSome scalar) + |> Seq.length + + holders = 1 + + seq { + for struct (dataMember, scalar) in scalars do + match scalar with + | ValueSome scalar when isUnique scalar -> + let writtenName = propertyHolding scalar present + + // A member that is never written and declares a name stands for a property that something else + // writes. Its name is no fact of these documents, and tests of their own state it. + let isDeclaredOnly = + writtenName.IsNone + && dataMember.IsDefined (typeof, false) + + let memberOfDocument = { Holder = documentType; Member = dataMember } + let name = layout.MemberName memberOfDocument + + if not isDeclaredOnly && name <> writtenName then + $"%s{dataMember.Name}: the layout names it %A{name}, the document %A{writtenName}" + + // What the member is without a value shows where it has one in one document and none in the other. + let memberType = ModelMembers.typeOf dataMember + + match + writtenName, + ModelMembers.unwrapped (ModelMembers.valueOf sample.Present dataMember) memberType, + ModelMembers.unwrapped (ModelMembers.valueOf sample.Absent dataMember) memberType + with + | ValueSome writtenAs, ValueSome (struct (inner, innerType)), ValueNone -> + // The value is written as itself when the property holds what the serializer writes for the + // value alone, whatever that is. + let alone = JsonSerializer.SerializeToElement (inner, innerType, options) + let isItself = present.GetProperty(writtenAs).GetRawText() = alone.GetRawText () + + let expected = + match isItself, absent.TryGetProperty writtenAs with + | true, (false, _) -> OptionalEncoding.AlwaysUndefined + | true, (true, left) when left.ValueKind = JsonValueKind.Null -> OptionalEncoding.AlwaysNull + | _ -> OptionalEncoding.NotDescribed + + let encoding = layout.OptionalEncoding (ValueSome memberOfDocument, memberType) + + if encoding <> expected then + $"%s{dataMember.Name}: the layout says %A{encoding} of it without a value, the documents %A{expected}" + | _ -> () + | _ -> () + } + |> Seq.toArray + + /// The layout of the options of a profile. + static let layoutOf (profile : SerializerProfile) : IJsonLayout = JsonLayout.ofSerializerOptions (profile.Create ()) + + /// A property of a type of the model, also one that is not public, as a value of that type has it. + static let propertyOf (documentType : Type) (name : string) : DocumentMember = + match + documentType.GetProperty ( + name, + BindingFlags.Instance + ||| BindingFlags.Public + ||| BindingFlags.NonPublic + ) + with + | null -> invalidOp $"%s{documentType.Name} has no property %s{name}." + | property -> { Holder = documentType; Member = property } + + /// + /// The property that a quotation reads from its parameter, as the quotation names it, with the type of the + /// parameter: what a translator has in its hands when it asks the layout. + /// + static let memberReadBy (reading : Expr) : DocumentMember = + match reading with + | Lambda (_, PropertyGet (Some receiver, property, [])) -> { Holder = receiver.Type; Member = property } + | other -> invalidArg (nameof reading) $"The quotation should read a property of its parameter: %A{other}" + + /// + /// What the serializer shows of how it writes a value without a value in a member: nothing when it fails to + /// write the holder, that it leaves the member out, or that it writes null. + /// + static let shownAbsent (options : JsonSerializerOptions) (held : DocumentMember) (holder : objnull) (name : string voption) = + try + let document = JsonSerializer.SerializeToElement (holder, held.Holder, options) + + match name with + | ValueSome name -> + match document.TryGetProperty name with + | true, written when written.ValueKind = JsonValueKind.Null -> OptionalEncoding.AlwaysNull + | true, _ -> OptionalEncoding.NotDescribed + | false, _ -> OptionalEncoding.AlwaysUndefined + | ValueNone -> OptionalEncoding.NotDescribed + with :? NullReferenceException -> + // A converter of FSharp.SystemTextJson that asks for the null and cannot write it. + OptionalEncoding.NotDescribed + + /// + /// Where what the layout says of a null of a type differs from what the serializer does with one, as texts for + /// a failure message: by itself, in a field of a record and in a property of a class. + /// + static let disagreementsAboutNull (options : JsonSerializerOptions) (valueType : Type) : string array = + let layout = JsonLayout.ofSerializerOptions options + let boxType = typedefof>.MakeGenericType valueType + let slotType = typedefof>.MakeGenericType valueType + + let ofBox = { + Holder = boxType + Member = nonNull (boxType.GetProperty (nameof Unchecked.defaultof>.Item)) + } + + let ofSlot = { + Holder = slotType + Member = nonNull (slotType.GetProperty (nameof Unchecked.defaultof>.Item)) + } + + seq { + let alone = + try + if JsonSerializer.SerializeToElement(null, valueType, options).ValueKind = JsonValueKind.Null then + OptionalEncoding.AlwaysNull + else + OptionalEncoding.NotDescribed + with :? NullReferenceException -> + OptionalEncoding.NotDescribed + + let saidAlone = layout.OptionalEncoding (ValueNone, valueType) + + if saidAlone <> alone then + $"by itself: the layout says %A{saidAlone}, the serializer shows %A{alone}" + + for struct (place, held, holder) in + seq { + struct ("in a record", ofBox, FSharpValue.MakeRecord (boxType, [| null; box (Some "label") |], true)) + struct ("in a class", ofSlot, nonNull (Activator.CreateInstance slotType)) + } do + let shown = shownAbsent options held holder (layout.MemberName held) + let said = layout.OptionalEncoding (ValueSome held, valueType) + + if said <> shown then + $"%s{place}: the layout says %A{said}, the serializer shows %A{shown}" + } + |> Seq.toArray + + /// The types of F# whose null the library writes in a way of its own, leaves out or fails to write. + static let typesWithNull = + seq { + struct ("a tuple", typeof) + struct ("a map with texts as keys", typeof>) + struct ("a map with numbers as keys", typeof>) + struct ("a union without fields", typeof) + struct ("a union", typeof) + struct ("a union with a case that is null", typeof) + struct ("a union that wraps an option", typeof) + struct ("a union that wraps a text", typeof) + struct ("a union that wraps a number", typeof) + struct ("a union that wraps a value option", typeof) + struct ("a union that wraps a skippable option", typeof) + struct ("a union that wraps a skippable text", typeof) + struct ("a union that wraps a value option of an option", typeof) + struct ("a union that wraps such a union", typeof) + struct ("a union that wraps the unit value", typeof) + struct ("a record", typeof) + struct ("a list", typeof) + struct ("a set", typeof>) + } + |> ImmutableArray.CreateRange + + /// The ways to set FSharp.SystemTextJson up that decide what becomes of such a null. + static let profilesForNull = + let profile + (name : string) + (configure : JsonFSharpOptions -> JsonFSharpOptions) + (ignoresNull : bool) + : SerializerProfile = { + Name = name + Create = + fun () -> + let options = (configure (JsonFSharpOptions.Default ())).ToJsonSerializerOptions() + + if ignoresNull then + options.DefaultIgnoreCondition <- JsonIgnoreCondition.WhenWritingNull + + options + HasFSharpConverter = true + } + + seq { + profile "FSharp.SystemTextJson as it is made" id false + profile "FSharp.SystemTextJson that ignores null" id true + profile "FSharp.SystemTextJson that lets a field of any type be null and ignores null" _.WithAllowNullFields() true + profile "FSharp.SystemTextJson that writes a case without fields as its tag" _.WithUnionUnwrapFieldlessTags() false + profile + "FSharp.SystemTextJson that writes a case without fields as its tag and ignores null" + _.WithUnionUnwrapFieldlessTags() + true + profile + "FSharp.SystemTextJson that does not write a union of one case as its value and ignores null" + _.WithUnionEncoding( + JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapOption + ) + true + profile + "FSharp.SystemTextJson that does not write an option as its value and ignores null" + _.WithUnionEncoding( + JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapSingleCaseUnions + ) + true + profile + "FSharp.SystemTextJson that always skips an option without a value and ignores null" + _.WithSkippableOptionFields(SkippableOptionFields.Always) + true + // The setting that always skips options makes them written as their values. Setting the encoding after + // it takes that back, and the library still skips them. + profile + "FSharp.SystemTextJson that always skips an option, does not write it as its value and ignores null" + (fun converterOptions -> + converterOptions + .WithSkippableOptionFields(SkippableOptionFields.Always) + .WithUnionEncoding( + JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapSingleCaseUnions + ) + ) + true + } + |> ImmutableArray.CreateRange + + /// Every such type with every such way to set the serializer up. + static member NullRows : IEnumerable> = seq { + for struct (name, valueType) in typesWithNull do + for profile in profilesForNull do + TestDataRow( + struct (valueType, profile), + DisplayName = $"a null of %s{name} must be laid out as it is written by %s{profile.Name}" + ) + } + + /// Every type of the model with every way to set the serializer up that can write it. + static member SampleRows : IEnumerable> = seq { + for profile in SerializerProfiles.all do + for sample in StoredSamples.all do + if profile.HasFSharpConverter || sample.IsPlain then + TestDataRow( + struct (profile, sample), + DisplayName = $"%s{sample.Name} must be laid out as it is written by %s{profile.Name}" + ) + } + + [] + member _.``A type must be laid out as the serializer writes it`` (profile : SerializerProfile, sample : StoredSample) = + let found = disagreements profile sample + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"The layout should name every member as the document does, and say of a member without a value what the documents show.\n%s{listed}" + ) + + [] + member _.``A null of a type of F# must be laid out as the serializer writes it`` + (valueType : Type, profile : SerializerProfile) + = + let found = disagreementsAboutNull (profile.Create ()) valueType + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"The layout should say of a null what the serializer does with it: null where it writes null, left out where it leaves the member out, and nothing where it fails.\n%s{listed}" + ) + + [] + member _.``The nulls of the types of F# must be written, left out and refused`` () = + // The test above compares the layout with what the serializer does. This one checks that the serializer does + // every one of the three things: a comparison with one outcome only would agree with a layout that knows one. + let ignoring = profilesForNull[1].Create() + let box = typeof>> + let ofBox = propertyOf box "Item" + let emptyBox : StoredBox> = { Item = Unchecked.defaultof>; Label = Some "label" } + + Assert.Throws( + Action (fun () -> + JsonSerializer.Serialize (Unchecked.defaultof>, profilesForNull[0].Create()) + |> ignore + ), + "FSharp.SystemTextJson should fail to write a map that is null, or the tests check nothing." + ) + |> ignore + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + (JsonLayout.ofSerializerOptions (profilesForNull[0].Create())) + .OptionalEncoding(ValueSome ofBox, typeof>), + "No document holds a map that is null where null is written, so nothing is described." + ) + + Assert.AreEqual( + "{\"Label\":\"label\"}", + JsonSerializer.Serialize (emptyBox, ignoring), + "The library should leave a map that is null out where null is ignored: a map is a class to it." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysUndefined, + (JsonLayout.ofSerializerOptions ignoring).OptionalEncoding(ValueSome ofBox, typeof>), + "So the member is left out." + ) + + let noteBox = typeof> + let captionBox = typeof> + + Assert.AreEqual( + OptionalEncoding.AlwaysUndefined, + (JsonLayout.ofSerializerOptions ignoring).OptionalEncoding(ValueSome (propertyOf noteBox "Item"), typeof), + "A union that is written as the option it wraps is null where the option has no value, so its null is a value, which is left out." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysNull, + (JsonLayout.ofSerializerOptions ignoring) + .OptionalEncoding(ValueSome (propertyOf captionBox "Item"), typeof), + "A union that is written as the text it wraps has no value that is null, so its null is written." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysUndefined, + (JsonLayout.ofSerializerOptions (profilesForNull[2].Create())) + .OptionalEncoding(ValueSome (propertyOf captionBox "Item"), typeof), + "Where the options let a field of any type be null, the text can be null, and so the null of the union is left out." + ) + + [] + member _.``A union in a record with options of its own must be null or left out by the encoding that the record inherits`` + () + = + // The options that the attribute of the record makes say that they inherit the encoding of unions. So the + // common options decide whether a union of one case is written as the value it wraps, and only then is its + // null a value, which is left out where null is ignored. + let withEncoding (encoding : JsonUnionEncoding) : JsonSerializerOptions = + let options = + JsonFSharpOptions.Default().WithUnionEncoding(encoding).WithAllowOverride().ToJsonSerializerOptions() + + options.DefaultIgnoreCondition <- JsonIgnoreCondition.WhenWritingNull + options + + let wrapped = propertyOf typeof "Wrapped" + let empty = { Wrapped = Unchecked.defaultof; Stated = "stated" } + + let asUnions = + withEncoding ( + JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapOption + ) + + Assert.AreEqual( + "{\"Wrapped\":null,\"Stated\":\"stated\"}", + JsonSerializer.Serialize (empty, asUnions), + "The library should write the union as a union, as the common encoding says, and so write its null, or the test checks nothing." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysNull, + (JsonLayout.ofSerializerOptions asUnions).OptionalEncoding(ValueSome wrapped, typeof), + "The encoding of the attribute would write the union as the option it wraps, and the record does not follow it." + ) + + let asValues = + withEncoding ( + JsonUnionEncoding.AdjacentTag + ||| JsonUnionEncoding.UnwrapOption + ||| JsonUnionEncoding.UnwrapSingleCaseUnions + ) + + Assert.AreEqual( + "{\"Stated\":\"stated\"}", + JsonSerializer.Serialize (empty, asValues), + "The library should leave the union out where the common encoding writes it as the option it wraps, or the test checks nothing." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysUndefined, + (JsonLayout.ofSerializerOptions asValues).OptionalEncoding(ValueSome wrapped, typeof), + "The null of the union is the option without a value there, which is left out." + ) + + [] + member _.``A skippable value must not be described where System.Text.Json alone would write it`` () = + // System.Text.Json has converters of its own for an option and for a value option, and none for a skippable + // value: it refuses one as it refuses any union. Where default values are ignored it leaves a skipped value + // out all the same, so the member is written as long as it has no value, and never with one. + let options = JsonSerializerOptions (DefaultIgnoreCondition = JsonIgnoreCondition.WhenWritingDefault) + + Assert.AreEqual( + "{\"Count\":1}", + JsonSerializer.Serialize (StoredSlot>(), options), + "System.Text.Json should leave a skipped value out where default values are ignored, or the test checks nothing." + ) + + Assert.Throws( + Action (fun () -> + JsonSerializer.Serialize (StoredSlot>(Item = Include 1), options) + |> ignore + ), + "System.Text.Json should refuse a skippable value that has a value, or the test checks nothing." + ) + |> ignore + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + (JsonLayout.ofSerializerOptions options) + .OptionalEncoding(ValueSome (propertyOf typeof>> "Item"), typeof>), + "A member that the serializer cannot write with a value is not described, also where it is left out without one." + ) + + [] + member _.``A null of a type that the serializer has no contract for must not be described`` () = + // The serializer needs the contract of a type also to write a null of it, alone or in a member. So it writes + // no document with a member of such a type, whatever the member holds. + let options = JsonSerializerOptions () + let layout = JsonLayout.ofSerializerOptions options + + Assert.Throws( + Action (fun () -> + JsonSerializer.Serialize (StoredSlot(), options) + |> ignore + ), + "System.Text.Json should refuse to write an object with a member of the type, also when the member is null, or the test checks nothing." + ) + |> ignore + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueSome (propertyOf typeof> "Item"), typeof), + "No document holds a member of the type, so the layout should not say how its null is written." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueNone, typeof), + "The serializer writes no null of the type by itself either." + ) + + [] + member _.``The model must be found in its documents member by member`` () = + // The test above compares the layout with what it finds in a document. This one checks that it finds + // something: a search that found nothing would agree with a layout that says nothing. + let written (profile : SerializerProfile) = + JsonSerializer.SerializeToElement (StoredSamples.entry.Present, typeof, profile.Create ()) + + let document = written SerializerProfiles.fsharpSystemTextJson + + Assert.AreEqual(ValueSome "Title", propertyHolding "title-1" document, "A text is found by its value.") + Assert.AreEqual(ValueSome "Count", propertyHolding 31 document, "A number is found by its value.") + Assert.AreEqual( + ValueNone, + propertyHolding "draft-1" document, + "A field that is never written is not found." + ) + + Assert.AreEqual( + ValueSome "Choice", + propertyHolding 32 (written SerializerProfiles.withoutUnwrappedOptions), + "The value of an option that is written as a union is found inside the property." + ) + + Assert.AreEqual( + ValueSome (struct (box (Some "nested-1"), typeof)), + ModelMembers.unwrapped (box (Some (Some "nested-1"))) typeof, + "One layer of an optional value is taken off at a time." + ) + + Assert.AreEqual( + ValueNone, + ModelMembers.unwrapped (box (Skip : Skippable)) typeof>, + "A skipped value has nothing under it." + ) + + [] + member _.``A member that is never written must have the name it declares`` () = + for profile in + seq { + SerializerProfiles.systemTextJson + SerializerProfiles.fsharpSystemTextJson + } do + let layout = layoutOf profile + + Assert.AreEqual( + ValueSome "$type", + layout.MemberName (propertyOf typeof "Discriminator"), + $"A property of a class that declares its name stands for a property that something else writes (%s{profile.Name})." + ) + + Assert.AreEqual( + ValueSome "$type", + layout.MemberName (propertyOf typeof "Discriminator"), + $"So does a field of a record (%s{profile.Name})." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Secret"), + $"A property that is never written and declares no name is in no document (%s{profile.Name})." + ) + + Assert.AreEqual( + OptionalEncoding.NullOrUndefined, + layout.OptionalEncoding (ValueSome (propertyOf typeof "Discriminator"), typeof), + $"The serializer does not write the property, so it cannot say how it is written without a value (%s{profile.Name})." + ) + + Assert.AreEqual( + OptionalEncoding.NullOrUndefined, + layout.OptionalEncoding (ValueSome (propertyOf typeof "Discriminator"), typeof), + $"Nor does it write the field of the record (%s{profile.Name})." + ) + + [] + member _.``A member that a derived class overrides must have the name of each declaration`` () = + let options = SerializerProfiles.systemTextJson.Create () + let layout = JsonLayout.ofSerializerOptions options + let document = + JsonSerializer.SerializeToElement (StoredSamples.person.Present, typeof, options) + + Assert.AreEqual( + ValueSome "pk", + layout.MemberName (propertyOf typeof "Tenant"), + "The declaration of the base class declares the name." + ) + + Assert.AreEqual( + ValueSome "Tenant", + layout.MemberName (propertyOf typeof "Tenant"), + "The override declares none, and the serializer does not take the name of the base class for it." + ) + + Assert.AreEqual( + "tenant of id-1", + document.GetProperty("pk").GetString(), + "The document holds the value under the declared name." + ) + Assert.AreEqual( + "tenant of id-1", + document.GetProperty("Tenant").GetString(), + "It holds it under the name of the override too." + ) + + [] + member _.``A member of a base class must have one name whichever class it is asked through`` () = + let layout = layoutOf SerializerProfiles.systemTextJson + + Assert.AreEqual( + layout.MemberName (propertyOf typeof "Note"), + layout.MemberName (propertyOf typeof "Note"), + "Reflection gives the same property through the derived class, with another reflected type." + ) + + Assert.AreEqual( + ValueSome "Note", + layout.MemberName (propertyOf typeof "Note"), + "It is named by the policy." + ) + + [] + member _.``The property that holds what no member stands for must have no name`` () = + let layout = layoutOf SerializerProfiles.systemTextJson + let extra = propertyOf typeof "Extra" + + Assert.AreEqual( + ValueNone, + layout.MemberName extra, + "Its entries are written as properties of the document itself, and it is not." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueSome extra, typeof>), + "Nothing is written for it when it is null, so no property of its name is null or missing." + ) + + [] + member _.``A member of a record that is not written must be laid out as one that something else writes`` () = + let options = SerializerProfiles.fsharpSystemTextJson.Create () + let layout = JsonLayout.ofSerializerOptions options + let written = + JsonSerializer.SerializeToElement (StoredSamples.entry.Present, typeof, options) + + for writtenName in + seq { + "Summary" + "Initial" + "first_letter" + "Whisper" + } do + Assert.IsFalse ( + fst (written.TryGetProperty writtenName), + $"FSharp.SystemTextJson should write no property %s{writtenName}: its member is no field and is not included." + ) + + for name in + seq { + "Summary" + "Initial" + "Whisper" + } do + Assert.AreEqual( + OptionalEncoding.NullOrUndefined, + layout.OptionalEncoding (ValueSome (propertyOf typeof name), typeof), + $"Whatever writes a property for %s{name} decides how it is written without a value." + ) + + Assert.AreEqual( + ValueSome "first_letter", + layout.MemberName (propertyOf typeof "Initial"), + "A member that is never written has the name it declares." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Summary"), + "And no name when it declares none." + ) + + [] + member _.``A member that code decides about must be null or undefined`` () = + let decided (configure : JsonSerializerOptions -> unit) : OptionalEncoding = + let options = JsonSerializerOptions () + + options.TypeInfoResolver <- + DefaultJsonTypeInfoResolver() + .WithAddedModifier(fun info -> + for property in info.Properties do + if property.Name = "Note" then + property.ShouldSerialize <- Func(fun _ value -> not (isNull value)) + ) + + configure options + + (JsonLayout.ofSerializerOptions options) + .OptionalEncoding(ValueSome (propertyOf typeof "Note"), typeof) + + Assert.AreEqual( + OptionalEncoding.NullOrUndefined, + decided ignore, + "A function decides whether the member is written, and a function says nothing before it is called." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + decided (fun options -> options.Converters.Add (StoredNullAsDashConverter ())), + "When the function has the member written, a converter that asks for the null writes it, as anything." + ) + + [] + member _.``A member of a type that the serializer refuses must have no name`` () = + let layout = layoutOf SerializerProfiles.systemTextJson + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Id"), + "The serializer writes no value of the type, so no document holds a member of it." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueSome (propertyOf typeof "Choice"), typeof), + "Nothing is known about how a member of it would be written." + ) + + [] + member _.``A member with a converter of its own must be null or left out as the serializer decides before it asks the converter`` + () + = + let memberOf (name : string) : DocumentMember voption = ValueSome (propertyOf typeof name) + let plain = JsonSerializerOptions () + let ignoringNull = JsonSerializerOptions (DefaultIgnoreCondition = JsonIgnoreCondition.WhenWritingNull) + let written = JsonLayout.ofSerializerOptions plain + let leftOut = JsonLayout.ofSerializerOptions ignoringNull + + Assert.AreEqual( + "{\"Day\":null,\"Topic\":null,\"Host\":\"-\",\"Alias\":null,\"Room\":null}", + JsonSerializer.Serialize (StoredMeeting (), plain), + "The serializer should write a null itself and ask only the converter that asks for it, or the test checks nothing." + ) + + Assert.AreEqual( + "{}", + JsonSerializer.Serialize (StoredMeeting (), ignoringNull), + "A null that the options leave out should get to no converter, or the test checks nothing." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysNull, + written.OptionalEncoding (memberOf "Day", typeof>), + "The converter of the member writes the day under the nullable; the serializer writes the null." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysNull, + written.OptionalEncoding (memberOf "Topic", typeof), + "A converter that does not ask for the null leaves it to the serializer, which writes null." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + written.OptionalEncoding (memberOf "Host", typeof), + "The converter of the member asks for the null and can write anything for it." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + written.OptionalEncoding (memberOf "Alias", typeof), + "The converter of the member writes the whole option, and nothing shows what it writes for a value of it." + ) + + for struct (name, valueType) in + seq { + struct ("Day", typeof>) + struct ("Topic", typeof) + struct ("Host", typeof) + } do + Assert.AreEqual( + OptionalEncoding.AlwaysUndefined, + leftOut.OptionalEncoding (memberOf name, valueType), + $"A null that the options leave out never gets to the converter of %s{name}." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + leftOut.OptionalEncoding (memberOf "Alias", typeof), + "An option of a member with a converter is not described, also where its null is left out: with a value it is what the converter writes." + ) + + [] + member _.``A member of a type that another converter writes must have no name`` () = + let options = SerializerProfiles.fsharpSystemTextJson.Create () + options.Converters.Insert (0, StoredPointAsTextConverter ()) + let layout = JsonLayout.ofSerializerOptions options + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "X"), + "The converter writes the point as a text, which has no members." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueSome (propertyOf typeof "Label"), typeof), + "So nothing is known about a member of it without a value." + ) + + [] + member _.``A member that a quotation reads must be laid out as the type it is read from is written`` () = + let inherited = memberReadBy <@ fun (talk : StoredTalk) -> talk.Room @> + + Assert.AreEqual( + typeof, + inherited.Member.ReflectedType, + "A quotation names an inherited property as the class that declares it has it, so the member does not tell which type it is read from." + ) + + Assert.AreEqual( + ValueSome "Room", + (layoutOf SerializerProfiles.systemTextJson).MemberName inherited, + "The serializer writes the derived class as an object, with the property that it inherits." + ) + + let options = JsonSerializerOptions () + options.Converters.Add (StoredTalkAsTextConverter ()) + let layout = JsonLayout.ofSerializerOptions options + + Assert.AreEqual( + ValueSome "Room", + layout.MemberName (memberReadBy <@ fun (meeting : StoredMeeting) -> meeting.Room @>), + "The serializer still writes the class that declares the member as an object." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName inherited, + "A converter writes the class that inherits the member as a text, which has no members." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueSome inherited, typeof), + "So nothing is known about the inherited member without a value." + ) + + [] + member _.``A member that a derived class overrides must be laid out as the override when it is read from that class`` () = + let layout = layoutOf SerializerProfiles.systemTextJson + + // The declaration of the base class, read from a value of the derived class: a quotation that code builds can + // name a property this way. + let declared (name : string) : DocumentMember = { + propertyOf typeof name with + Holder = typeof + } + + Assert.AreEqual( + ValueSome "pk", + layout.MemberName (declared "Tenant"), + "The document of the derived class holds the declaration of the base class too, under the name that it declares." + ) + + Assert.AreEqual( + ValueSome "Remark", + layout.MemberName (declared "Remark"), + "The document holds this property once, as the override, so the override is what the layout describes." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysNull, + layout.OptionalEncoding (ValueSome (declared "Remark"), typeof), + "The override declares no condition of its own, so it is written as null, whatever the declaration that it overrides says." + ) + + // A quotation that the compiler stores names the override itself. + let quoted = memberReadBy <@ fun (person : StoredPerson) -> person.Remark @> + + Assert.AreEqual( + typeof, + quoted.Member.DeclaringType, + "The quotation of compiled code names the property as the derived class declares it." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysNull, + layout.OptionalEncoding (ValueSome quoted, typeof), + "The override is described the same way when it is named itself." + ) + + [] + member _.``A record that names a converter of its own must be described only when a converter of the options writes it`` () = + let span = { From = 3; To = 5; Note = None } + let from = propertyOf typeof "From" + let note = propertyOf typeof "Note" + + // The serializer asks the converters of the options before the attribute of a type. + let named = SerializerProfiles.systemTextJson.Create () + + Assert.AreEqual( + "\"3-5\"", + JsonSerializer.Serialize (span, named), + "The converter that the record names should write it, or the test checks nothing." + ) + + let layout = JsonLayout.ofSerializerOptions named + + Assert.AreEqual( + ValueNone, + layout.MemberName from, + "The named converter writes the record as a text, which has no members." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueSome note, typeof), + "So nothing is known about a member of it without a value." + ) + + let common = SerializerProfiles.fsharpSystemTextJson.Create () + + Assert.AreEqual( + """{"From":3,"To":5,"Note":null}""", + JsonSerializer.Serialize (span, common), + "The converter of the options should write the record, or the test checks nothing." + ) + + let layout = JsonLayout.ofSerializerOptions common + + Assert.AreEqual( + ValueSome "From", + layout.MemberName from, + "FSharp.SystemTextJson writes the record, whatever converter the record names." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysNull, + layout.OptionalEncoding (ValueSome note, typeof), + "So an option of it without a value is written as FSharp.SystemTextJson writes it." + ) + + [] + member _.``A value whose converter writes null itself must not be described where null is written`` () = + let withConverter (converter : JsonConverter) (configure : JsonSerializerOptions -> unit) : IJsonLayout = + let options = JsonSerializerOptions () + options.Converters.Add converter + configure options + JsonLayout.ofSerializerOptions options + + let note = propertyOf typeof "Note" + let asked = withConverter (StoredNullAsDashConverter ()) ignore + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + asked.OptionalEncoding (ValueSome note, typeof), + "The converter asks for the null and can write anything for it." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + asked.OptionalEncoding (ValueNone, typeof), + "So it does for an item of a collection, which is always written." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysUndefined, + (withConverter + (StoredNullAsDashConverter ()) + (fun options -> options.DefaultIgnoreCondition <- JsonIgnoreCondition.WhenWritingNull)) + .OptionalEncoding(ValueSome note, typeof), + "A null that the options leave out never gets to the converter." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysNull, + (withConverter (StoredTextConverter ()) ignore).OptionalEncoding(ValueSome note, typeof), + "A converter that does not ask for the null leaves it to the serializer, which writes null." + ) + + [] + member _.``A record that a factory made of the one of FSharp.SystemTextJson writes itself must not be described`` () = + let options = JsonSerializerOptions () + options.Converters.Add (StoredPointFactory ()) + let layout = JsonLayout.ofSerializerOptions options + + Assert.AreEqual( + "\"51\"", + JsonSerializer.Serialize (StoredSamples.point.Present, typeof, options), + "The factory should write the point with a converter of its own, or the test checks nothing." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "X"), + "The contract names the converter that writes the point, and it is not the one for records." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof> "Item"), + "A record that this factory leaves to FSharp.SystemTextJson is not described either: a factory of an application can make that converter with other options than the ones it shows." + ) + + [] + member _.``A record that a factory made of the one of FSharp.SystemTextJson writes with options of its own must not be described`` + () + = + let options = JsonSerializerOptions () + options.Converters.Add (StoredQuietFactory ()) + let layout = JsonLayout.ofSerializerOptions options + let author : StoredAuthor = { Name = "name-1" } + + Assert.AreEqual( + "{\"name\":\"name-1\"}", + JsonSerializer.Serialize (author, options), + "The factory should write the record with the converter of FSharp.SystemTextJson and names in snake case, which neither its own options nor the ones of the serializer say." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Name"), + "Only the factory of FSharp.SystemTextJson itself shows the options that a record is written with." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueSome (propertyOf typeof "Name"), typeof), + "So nothing is known about a field of the record without a value." + ) + + [] + member _.``A record whose contract a resolver of the caller makes must not be described`` () = + let author : StoredAuthor = { Name = "name-1" } + let name = propertyOf typeof "Name" + + // The converter of FSharp.SystemTextJson for a record, made with options that nothing shows. + let quiet (recordType : Type) : JsonConverter = nonNull (StoredConverters.quietRecordConverter recordType) + + let options = + JsonSerializerOptions ( + SerializerProfiles.fsharpSystemTextJson.Create (), + TypeInfoResolver = + StoredContractResolver(fun options -> + JsonMetadataServices.CreateValueInfo(options, quiet typeof) + ) + ) + + let layout = JsonLayout.ofSerializerOptions options + + Assert.AreEqual( + "{\"name\":\"name-1\"}", + JsonSerializer.Serialize (author, options), + "The resolver should have the record written with the converter of FSharp.SystemTextJson and names in snake case, which the converter among the options does not say, or the test checks nothing." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName name, + "The serializer did not make the contract of the record, so the converter among the options does not tell how the record is written." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueSome name, typeof), + "So nothing is known about a field of the record without a value." + ) + + // The same resolver leaves every other type to the serializer, as a resolver does that an application derives + // from the one of the serializer to change some contracts. + let passing = + JsonSerializerOptions ( + SerializerProfiles.fsharpSystemTextJson.Create (), + TypeInfoResolver = + StoredContractResolver(fun options -> + JsonMetadataServices.CreateValueInfo(options, quiet typeof) + ) + ) + + Assert.AreEqual( + "{\"Name\":\"name-1\"}", + JsonSerializer.Serialize (author, passing), + "The converter among the options should write the record, or the test checks nothing." + ) + + Assert.AreEqual( + ValueSome "Name", + (JsonLayout.ofSerializerOptions passing).MemberName name, + "The serializer made the contract of the record, also as the class that the application derives from its resolver, so the converter among the options tells how the record is written." + ) + + [] + member _.``A member with a converter of its own must be laid out by that converter when a resolver of the caller makes the contract of its type`` + () + = + // The resolver makes the contract of an array of texts itself, as an array. + let options = + JsonSerializerOptions ( + IgnoreReadOnlyProperties = true, + TypeInfoResolver = + StoredContractResolver(fun options -> + JsonMetadataServices.CreateArrayInfo( + options, + JsonCollectionInfoValues(ObjectCreator = Func(fun () -> [||])) + ) + ) + ) + + let layout = JsonLayout.ofSerializerOptions options + + let written = + JsonSerializer.SerializeToElement (StoredSamples.person.Present, typeof, options) + + let isWritten (name : string) : bool = + let found, _ = written.TryGetProperty name + found + + Assert.IsTrue ( + isWritten "Marks", + "The serializer should write a read-only array by the contract of the resolver, as a collection, or the test checks nothing." + ) + + Assert.IsFalse ( + isWritten "Labels", + "The serializer should write the member with the converter that the member names, whatever contract the resolver makes for its type: as one text it is no collection, so it is left out for being read-only." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Labels"), + "The converter of the member decides whether the member is a collection, and not the contract that the resolver makes for its type." + ) + + Assert.AreEqual( + ValueSome "Marks", + layout.MemberName (propertyOf typeof "Marks"), + "A member without a converter of its own is written by the contract of the resolver." + ) + + [] + member _.``A member of a union must not be described`` () = + let options = SerializerProfiles.fsharpSystemTextJson.Create () + let layout = JsonLayout.ofSerializerOptions options + let tag = propertyOf typeof "Tag" + + Assert.AreEqual( + "{\"Case\":\"Marked\",\"Fields\":[3]}", + JsonSerializer.Serialize (Marked 3, options), + "FSharp.SystemTextJson should write the union in its own way, or the test checks nothing." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName tag, + "The converter among the options takes a union as it takes a record, and writes it with another converter, which the layout does not describe." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueSome tag, typeof), + "So nothing is known about a member of the union without a value." + ) + + [] + member _.``A layout must ask the serializer about a member once`` () = + let layout = JsonLayout.ofSerializerOptions (JsonSerializerOptions (IgnoreReadOnlyProperties = true)) + let stamps = propertyOf typeof "Stamps" + let first = layout.MemberName stamps + let madeForFirst = StoredCountingConverterFactory.Made + let second = layout.MemberName stamps + + Assert.AreEqual( + ValueSome "Stamps", + first, + "The factory of the member hands the collection to the converter of the options, so the serializer writes it although it is read-only." + ) + + Assert.AreEqual(first, second, "The answer is the same every time.") + + Assert.AreEqual( + madeForFirst, + StoredCountingConverterFactory.Made, + "The layout has the factory of the member make a converter to find the answer, and remembers the answer: the factory made no converter for the second one." + ) + + [] + member _.``A layout must ask the serializer about a member once when several threads ask at a time`` () : Task = task { + let layout = JsonLayout.ofSerializerOptions (JsonSerializerOptions (IgnoreReadOnlyProperties = true)) + let stamps = propertyOf typeof "Stamps" + + // One thread has the contract of the class made first: the serializer asks the factory for it by itself. + layout.MemberName (propertyOf typeof "Title") + |> ignore + + let madeBefore = StoredGatedConverterFactory.Made + StoredGatedConverterFactory.Gate.Reset () + + let asking = Array.init 4 (fun _ -> Task.Run (fun () -> layout.MemberName stamps)) + + // The first thread waits inside the factory. The others get the time to come there too, which they would do + // if every thread worked the answer out for itself. + let entered = + SpinWait.SpinUntil ((fun () -> StoredGatedConverterFactory.Made > madeBefore), TimeSpan.FromSeconds 10.0) + + do! Task.Delay 200 + StoredGatedConverterFactory.Gate.Set () + let! names = Task.WhenAll asking + + Assert.IsTrue (entered, "A thread should have asked the factory of the member.") + + Assert.AreEqual( + madeBefore + 1, + StoredGatedConverterFactory.Made, + "One thread works the answer out, and the others wait for it: the factory made one converter for the four of them." + ) + + Assert.IsTrue ( + names + |> Array.forall (fun name -> name = ValueSome "Stamps"), + "Every thread should get the answer." + ) + } + + [] + member _.``A record whose converter an attribute of the caller makes must not be described`` () = + let card = { FirstName = "a"; NickName = None } + let firstName = propertyOf typeof "FirstName" + let options = SerializerProfiles.systemTextJson.Create () + let layout = JsonLayout.ofSerializerOptions options + + Assert.AreEqual( + "{\"first_name\":\"a\"}", + JsonSerializer.Serialize (card, options), + "The converter of the attribute should write the record with its own options, or the test checks nothing." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName firstName, + "Nothing shows the options that the attribute made the converter with, so the layout should not guess a name." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueSome (propertyOf typeof "NickName"), typeof), + "Nor should it guess how an option of the record is written without a value." + ) + + // The serializer asks the converters of the options before the attribute of a type. + let common = SerializerProfiles.fsharpSystemTextJson.Create () + + Assert.AreEqual( + "{\"FirstName\":\"a\",\"NickName\":null}", + JsonSerializer.Serialize (card, common), + "The converter of the options should write the record, or the test checks nothing." + ) + + Assert.AreEqual( + ValueSome "FirstName", + (JsonLayout.ofSerializerOptions common).MemberName firstName, + "The converter of the options writes the record, with options that the layout reads." + ) + + [] + member _.``A read-only member with a rule that code has set must have its name when the options ignore read-only members`` + () + = + let options = JsonSerializerOptions (IgnoreReadOnlyProperties = true) + + options.TypeInfoResolver <- + DefaultJsonTypeInfoResolver() + .WithAddedModifier(fun info -> + for property in info.Properties do + if property.Name = "Name" then + property.ShouldSerialize <- Func(fun _ _ -> true) + ) + + let layout = JsonLayout.ofSerializerOptions options + let written = + JsonSerializer.SerializeToElement (StoredSamples.person.Present, typeof, options) + + Assert.IsTrue ( + fst (written.TryGetProperty "Name"), + "The serializer should ask the rule and write the read-only property, or the test checks nothing." + ) + + Assert.IsFalse (fst (written.TryGetProperty "Id"), "And it should leave a read-only property without a rule out.") + + Assert.AreEqual( + ValueSome "Name", + layout.MemberName (propertyOf typeof "Name"), + "The rule decides, and not the option that ignores read-only members, so the member has its name." + ) + + Assert.AreEqual( + OptionalEncoding.NullOrUndefined, + layout.OptionalEncoding (ValueSome (propertyOf typeof "Name"), typeof), + "A function decides whether the member is written, and a function says nothing before it is called." + ) + + [] + member _.``A value that is no member must be null without a value`` () = + for profile in + seq { + SerializerProfiles.systemTextJson + SerializerProfiles.fsharpSystemTextJson + } do + let layout = layoutOf profile + + for valueType in + seq { + typeof + typeof + typeof> + typeof + } do + Assert.AreEqual( + OptionalEncoding.AlwaysNull, + layout.OptionalEncoding (ValueNone, valueType), + $"An item of a collection is always written, so %s{valueType.Name} without a value is null (%s{profile.Name})." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueNone, typeof), + $"A number always has a value (%s{profile.Name})." + ) + + Assert.AreEqual( + OptionalEncoding.AlwaysNull, + (layoutOf SerializerProfiles.fsharpSystemTextJson).OptionalEncoding(ValueNone, typeof>), + "FSharp.SystemTextJson writes a skipped value that it cannot leave out as null." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + (layoutOf SerializerProfiles.systemTextJson).OptionalEncoding(ValueNone, typeof>), + "System.Text.Json alone cannot write a skippable value at all." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + (layoutOf SerializerProfiles.withoutUnwrappedOptions).OptionalEncoding(ValueNone, typeof), + "An option that is written as a union with the name of its case is not described yet." + ) + + [] + member _.``The layout must leave the options it is made of as they are, and not follow a later change of them`` () = + for profile in + seq { + SerializerProfiles.systemTextJson + SerializerProfiles.fsharpSystemTextJson + } do + let options = profile.Create () + let layout = JsonLayout.ofSerializerOptions options + let comment = propertyOf typeof "Comment" + + Assert.IsFalse (options.IsReadOnly, $"The caller may still have to finish the options (%s{profile.Name}).") + Assert.IsNull ( + options.TypeInfoResolver, + $"The layout should give the options of the caller no resolver (%s{profile.Name})." + ) + + options.PropertyNamingPolicy <- JsonNamingPolicy.CamelCase + + Assert.AreEqual( + ValueSome "Comment", + layout.MemberName comment, + $"A change of the options after the layout is made does not reach it, also for a member that it is asked about for the first time (%s{profile.Name})." + ) + + Assert.AreEqual( + ValueSome "comment", + (JsonLayout.ofSerializerOptions options).MemberName comment, + $"A layout that is made after the change has it (%s{profile.Name})." + ) + + [] + member _.``The layout must ask the resolver that the options have, and leave it and the options as they are`` () = + // The resolver gives one property another name, which no attribute and no policy says. + let resolver = + DefaultJsonTypeInfoResolver() + .WithAddedModifier(fun (info : JsonTypeInfo) -> + for property in info.Properties do + if + Type.(=) (info.Type, typeof) + && String.Equals (property.Name, "Comment", StringComparison.Ordinal) + then + property.Name <- "remark" + ) + + let options = JsonSerializerOptions (TypeInfoResolver = resolver) + let layout = JsonLayout.ofSerializerOptions options + + Assert.AreEqual( + ValueSome "remark", + layout.MemberName (propertyOf typeof "Comment"), + "The layout should give the name that the resolver of the caller gives, as the serializer does." + ) + + Assert.IsFalse (options.IsReadOnly, "The caller may still have to finish the options.") + Assert.AreSame( + resolver, + options.TypeInfoResolver, + "The options of the caller should keep the resolver they were given." + ) + + [] + member _.``The resolver that the layout shares with the serializer must take no change once the layout has asked it`` () = + // A resolver cannot be copied, so the layout asks the one that the serializer asks. + let rename = + Action(fun info -> + if Type.(=) (info.Type, typeof) then + for property in info.Properties do + if String.Equals (property.Name, "Comment", StringComparison.Ordinal) then + property.Name <- "remark" + ) + + let resolver = DefaultJsonTypeInfoResolver () + let options = JsonSerializerOptions (TypeInfoResolver = resolver) + let layout = JsonLayout.ofSerializerOptions options + + resolver.Modifiers.Add rename + + Assert.AreEqual( + ValueSome "remark", + layout.MemberName (propertyOf typeof "Comment"), + "A change of the resolver before the layout is asked should reach the layout, as it reaches the serializer." + ) + + Assert.Throws( + Action (fun () -> resolver.Modifiers.Add rename), + "The resolver should take no change after the layout has asked it: a change that reached only the serializer would go unnoticed." + ) + |> ignore + + let written = + JsonSerializer.SerializeToElement (StoredSamples.entry.Present, typeof, options) + + Assert.IsTrue ( + fst (written.TryGetProperty "remark"), + "The serializer should write the name that the layout gives: both asked one resolver." + ) + + [] + member _.``A member that is left out because it is read-only must have the name it declares, and be null or undefined`` () = + // System.Text.Json writes the record as an object here, and every field of a record is read-only. + let options = JsonSerializerOptions (IgnoreReadOnlyProperties = true) + let layout = JsonLayout.ofSerializerOptions options + let written = + JsonSerializer.SerializeToElement (StoredSamples.entry.Present, typeof, options) + + Assert.IsFalse ( + fst (written.TryGetProperty "Title"), + "The serializer should leave a read-only property out, or the test checks nothing." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName (propertyOf typeof "Title"), + "A member that is never written and declares no name has none." + ) + + Assert.AreEqual( + ValueSome "body_text", + layout.MemberName (propertyOf typeof "Body"), + "A member that is never written has the name it declares: it stands for a property that something else writes." + ) + + Assert.AreEqual( + OptionalEncoding.NullOrUndefined, + layout.OptionalEncoding (ValueSome (propertyOf typeof "Choice"), typeof), + "The serializer does not write the property, so it cannot say how it is written without a value." + ) + + Assert.AreEqual( + ValueSome "Dropped", + layout.MemberName (propertyOf typeof "Dropped"), + "A member that says itself when it is ignored is not left out for being read-only." + ) + + [] + member _.``A field that is read-only must have no name when the options ignore read-only fields`` () = + // F# declares a field that is not mutable as a property, so a type with a public read-only field is made here. + let documentType = + let assembly = + AssemblyBuilder.DefineDynamicAssembly (AssemblyName "StoredFields", AssemblyBuilderAccess.Run) + + let declared = + assembly + .DefineDynamicModule("StoredFields") + .DefineType("StoredFields", TypeAttributes.Public ||| TypeAttributes.Class) + + declared.DefineField ("Fixed", typeof, FieldAttributes.Public ||| FieldAttributes.InitOnly) + |> ignore + + declared.DefineField ("Free", typeof, FieldAttributes.Public) + |> ignore + + declared.DefineDefaultConstructor MethodAttributes.Public + |> ignore + + declared.CreateType () + + let fieldOf (name : string) : FieldInfo = + match documentType.GetField name with + | null -> invalidOp $"The type has no field %s{name}." + | field -> field + + let document = Activator.CreateInstance documentType + (fieldOf "Fixed").SetValue(document, "fixed") + (fieldOf "Free").SetValue(document, "free") + + let namesWith (ignoresReadOnly : bool) = + let options = JsonSerializerOptions (IncludeFields = true, IgnoreReadOnlyFields = ignoresReadOnly) + let layout = JsonLayout.ofSerializerOptions options + let written = JsonSerializer.SerializeToElement (document, documentType, options) + + struct {| + Written = written.EnumerateObject () |> Seq.map _.Name |> Seq.toArray + Fixed = layout.MemberName { Holder = documentType; Member = fieldOf "Fixed" } + Free = layout.MemberName { Holder = documentType; Member = fieldOf "Free" } + |} + + let kept = namesWith false + let ignored = namesWith true + + CollectionAssert.AreEquivalent ( + [| "Fixed"; "Free" |], + kept.Written, + "The serializer should write both fields, or the test checks nothing." + ) + + Assert.AreEqual( + ValueSome "Fixed", + kept.Fixed, + "A read-only field is written unless the options say otherwise." + ) + + CollectionAssert.AreEqual ( + [| "Free" |], + ignored.Written, + "The serializer should leave the read-only field out, or the test checks nothing." + ) + + Assert.AreEqual(ValueNone, ignored.Fixed, "A field that is never written and declares no name has none.") + Assert.AreEqual(ValueSome "Free", ignored.Free, "A field that can be assigned is written.") + + [] + member _.``A record whose converter stands among the options by itself must not be described`` () = + // The converter is made with options of its own, which nothing lets a layout read. + let options = JsonSerializerOptions () + + options.Converters.Add ( + JsonRecordConverter>( + options, + JsonFSharpOptions.Default().WithSkippableOptionFields SkippableOptionFields.Always + ) + ) + + let layout = JsonLayout.ofSerializerOptions options + let label = propertyOf typeof> "Label" + + Assert.AreEqual( + """{"Item":72}""", + JsonSerializer.Serialize (StoredSamples.box.Absent, typeof>, options), + "The converter should write the record with its own options, or the test checks nothing." + ) + + Assert.AreEqual( + ValueNone, + layout.MemberName label, + "The rules of the converter are not known, so the layout should not guess the name." + ) + + Assert.AreEqual( + OptionalEncoding.NotDescribed, + layout.OptionalEncoding (ValueSome label, typeof), + "Nor should it guess how the field is written without a value." + ) diff --git a/tests/Cosmos.Quotations.Tests/JsonLayoutUnionTests.fs b/tests/Cosmos.Quotations.Tests/JsonLayoutUnionTests.fs new file mode 100644 index 00000000..0132aecc --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/JsonLayoutUnionTests.fs @@ -0,0 +1,752 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open System.Reflection +open System.Text.Json +open System.Text.Json.Serialization +open System.Text.Json.Serialization.Metadata +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Reflection + +open FSharp.Azure.Cosmos +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// +/// What says about unions, compared with what the +/// serializer writes for them. A value of every case of the model of unions is written with every way to set the +/// serializer up. The document has to hold the mark that the layout gives the case, and no mark of another case, and +/// the value of every field at the place that the layout gives it. +/// +[] +type JsonLayoutUnionTests () = + + /// The steps of a path as a query would write them, for a failure message. + static let shown (path : ImmutableArray) : string = + path + |> Seq.map (fun step -> + match step with + | JsonStep.Property name -> $"[\"%s{name}\"]" + | JsonStep.Item index -> $"[%d{index}]" + ) + |> String.concat "" + + /// The JSON value at the end of the steps that start at a value; none when a step leads nowhere. + static let valueAt (path : ImmutableArray) (start : JsonElement) : JsonElement voption = + path + |> Seq.fold + (fun (reached : JsonElement voption) (step : JsonStep) -> + reached + |> ValueOption.bind (fun value -> + match step with + | JsonStep.Property name when value.ValueKind = JsonValueKind.Object -> + match value.TryGetProperty name with + | true, found -> ValueSome found + | false, _ -> ValueNone + | JsonStep.Item index when + value.ValueKind = JsonValueKind.Array + && index < value.GetArrayLength () + -> + ValueSome value[index] + | _ -> ValueNone + ) + ) + (ValueSome start) + + /// Whether a JSON value is a tag. + static let isTag (tag : UnionTag) (value : JsonElement) : bool = + match tag, value.ValueKind with + | UnionTag.String text, JsonValueKind.String -> String.Equals (value.GetString (), text, StringComparison.Ordinal) + | UnionTag.Number number, JsonValueKind.Number -> value.GetInt32 () = number + | UnionTag.Boolean true, JsonValueKind.True + | UnionTag.Boolean false, JsonValueKind.False -> true + | _ -> false + + /// Whether a written value has a mark; no answer for the mark that nothing is written for. + static let hasMark (mark : UnionCaseMark) (written : JsonElement) : bool voption = + match mark with + | UnionCaseMark.Tag (path, tag) -> ValueSome (valueAt path written |> ValueOption.exists (isTag tag)) + | UnionCaseMark.Property name -> + let isHeld = + written.ValueKind = JsonValueKind.Object + && ( + match written.TryGetProperty name with + | found, _ -> found + ) + + ValueSome isHeld + | UnionCaseMark.Null -> ValueSome (written.ValueKind = JsonValueKind.Null) + | UnionCaseMark.Unmarked -> ValueNone + + /// The case and the values of the fields of a value of a union. + static let caseOf (unionType : Type) (value : objnull) : struct (UnionCaseInfo * objnull array) = + let case, values = FSharpValue.GetUnionFields (value, unionType, true) + struct (case, values) + + /// + /// Where what the layout says of the case of a value differs from what the serializer wrote for the value, as + /// texts for a failure message. The mark of the case has to be in the document and the mark of no other case; the + /// value of every field has to be at its place, written as the serializer writes a value of its type. A field + /// without a value that the serializer left out is not looked for. + /// + static let disagreementsAbout + (layout : IJsonLayout) + (options : JsonSerializerOptions) + (memberOfDocument : DocumentMember voption) + (unionType : Type) + (value : objnull) + (written : JsonElement) + : string seq = seq { + let struct (case, values) = caseOf unionType value + let named = $"%s{unionType.Name}.%s{case.Name}, written as %s{written.GetRawText ()}" + + match layout.UnionCaseEncoding (memberOfDocument, case) with + | UnionCaseEncoding.NotDescribed -> $"%s{named}: the layout does not describe the case" + | UnionCaseEncoding.Written (mark, places) -> + if hasMark mark written = ValueSome false then + $"%s{named}: the mark %A{mark} is not in the document" + + for other in FSharpType.GetUnionCases (unionType, true) do + if other.Tag <> case.Tag then + match layout.UnionCaseEncoding (memberOfDocument, other) with + | UnionCaseEncoding.Written (otherMark, _) when hasMark otherMark written = ValueSome true -> + $"%s{named}: the mark of the case %s{other.Name} is in the document too" + | _ -> () + + let fields = case.GetFields () + + if places.Length <> fields.Length then + $"%s{named}: the layout has %d{places.Length} places for %d{fields.Length} fields" + else + for index in 0 .. fields.Length - 1 do + let field = fields[index] + let expected = JsonSerializer.SerializeToElement (values[index], field.PropertyType, options) + + match places[index] with + | UnionFieldPlace.Value path -> + match valueAt path written with + | ValueSome found when JsonElement.DeepEquals (found, expected) -> () + // A field without a value can be left out, as a field of a record can. + | ValueNone when expected.ValueKind = JsonValueKind.Null -> () + | _ -> $"%s{named}: the field %s{field.Name} is not at %s{shown path}" + | UnionFieldPlace.Members path -> + match valueAt path written with + | ValueSome holder when holder.ValueKind = JsonValueKind.Object -> + for dataMember in FSharpType.GetRecordFields (field.PropertyType, true) do + let ofRecord = { Holder = field.PropertyType; Member = dataMember } + + let expected = + JsonSerializer.SerializeToElement ( + dataMember.GetValue values[index], + dataMember.PropertyType, + options + ) + + match layout.MemberName ofRecord with + | ValueSome name -> + match holder.TryGetProperty name with + | true, found when JsonElement.DeepEquals (found, expected) -> () + | _ -> + $"%s{named}: the member %s{dataMember.Name} of the record is not at %s{shown path}[\"%s{name}\"]" + | ValueNone -> + $"%s{named}: the layout has no name for the member %s{dataMember.Name} of the record" + | _ -> $"%s{named}: no object is at %s{shown path} for the members of the record" + } + + /// What the serializer writes for a value; none when it refuses the type. + static let written (options : JsonSerializerOptions) (valueType : Type) (value : objnull) : JsonElement voption = + try + ValueSome (JsonSerializer.SerializeToElement (value, valueType, options)) + with :? NotSupportedException -> + ValueNone + + /// + /// What the serializer writes for each of some values of one type; none when it refuses one of them. System.Text.Json + /// refuses a union when it is to write a value of it, and writes a null without asking what it is a null of, so + /// the union with a case that is null is refused as the other unions are. + /// + static let writtenAll + (options : JsonSerializerOptions) + (valueType : Type) + (values : objnull seq) + : struct (objnull * JsonElement) array voption = + let documents = + values + |> Seq.map (fun value -> struct (value, written options valueType value)) + |> Seq.toArray + + if + documents + |> Array.forall (fun (struct (_, document)) -> document.IsSome) + then + documents + |> Array.map (fun (struct (value, document)) -> struct (value, document.Value)) + |> ValueSome + else + ValueNone + + /// The cases of a union that a layout describes although it should describe none, as texts for a failure message. + static let describedCasesOf + (layout : IJsonLayout) + (memberOfDocument : DocumentMember voption) + (unionType : Type) + (reason : string) + : string seq = seq { + for case in FSharpType.GetUnionCases (unionType, true) do + if not (layout.UnionCaseEncoding (memberOfDocument, case)).IsNotDescribed then + $"%s{unionType.Name}.%s{case.Name}: %s{reason}, and the layout describes the case" + } + + /// + /// Everything the layout says about the unions of the model that a way to set the serializer up does not confirm, + /// when each value is written by itself; empty when the layout is right. A union that the serializer refuses has + /// to be not described. + /// + static let disagreementsAlone (profile : SerializerProfile) : string array = + let options = profile.Create () + let layout = JsonLayout.ofSerializerOptions options + + seq { + for sample in StoredUnionSamples.all do + match writtenAll options sample.UnionType sample.Values with + | ValueSome documents -> + for struct (value, document) in documents do + yield! disagreementsAbout layout options ValueNone sample.UnionType value document + | ValueNone -> yield! describedCasesOf layout ValueNone sample.UnionType "the serializer refuses the union" + } + |> Seq.toArray + + /// + /// The same for the values as a member of a record holds them: the layout is asked about the member, and the + /// value is looked for under the name that the layout gives the member. + /// + static let disagreementsHeld (profile : SerializerProfile) : string array = + let options = profile.Create () + let layout = JsonLayout.ofSerializerOptions options + + seq { + for sample in StoredUnionSamples.all do + let holderType = typedefof>.MakeGenericType sample.UnionType + let held = { + Holder = holderType + Member = nonNull (holderType.GetProperty (nameof Unchecked.defaultof>.Held)) + } + + let holders = + sample.Values + |> Seq.map (fun value -> FSharpValue.MakeRecord (holderType, [| value |], true)) + |> Seq.cast + + match writtenAll options holderType holders, layout.MemberName held with + | ValueSome documents, ValueSome name -> + for struct (holder, document) in documents do + let value = held.Member :?> PropertyInfo |> _.GetValue(holder) + + match document.TryGetProperty name with + | true, found -> yield! disagreementsAbout layout options (ValueSome held) sample.UnionType value found + | false, _ -> + // A null that the serializer left out: only the case that is null is written that way. + let struct (case, _) = caseOf sample.UnionType value + + match layout.UnionCaseEncoding (ValueSome held, case) with + | UnionCaseEncoding.Written (UnionCaseMark.Null, _) -> () + | said -> + $"%s{sample.UnionType.Name}.%s{case.Name}: the document does not hold the member, and the layout says %A{said}" + | ValueNone, _ -> + yield! describedCasesOf layout (ValueSome held) sample.UnionType "the serializer refuses the union" + | _, ValueNone -> + yield! describedCasesOf layout (ValueSome held) sample.UnionType "the serializer never writes the member" + } + |> Seq.toArray + + /// A union case by its name. + static let caseNamed (unionType : Type) (name : string) : UnionCaseInfo = + FSharpType.GetUnionCases (unionType, true) + |> Array.find (fun case -> String.Equals (case.Name, name, StringComparison.Ordinal)) + + /// What a layout says of a case, as a text that two answers with the same steps share. + static let described (encoding : UnionCaseEncoding) : string = + match encoding with + | UnionCaseEncoding.NotDescribed -> "not described" + | UnionCaseEncoding.Written (mark, places) -> + let markShown = + match mark with + | UnionCaseMark.Tag (path, tag) -> $"tag %A{tag} at value%s{shown path}" + | UnionCaseMark.Property name -> $"property %s{name}" + | UnionCaseMark.Null -> "null" + | UnionCaseMark.Unmarked -> "unmarked" + + let placesShown = + places + |> Seq.map (fun place -> + match place with + | UnionFieldPlace.Value path -> $"value%s{shown path}" + | UnionFieldPlace.Members path -> $"members of value%s{shown path}" + ) + |> String.concat ", " + + $"%s{markShown}; fields: %s{placesShown}" + + /// Every way to have the name of the tag written twice, as a row of a data-driven test. + static member TagTwiceRows : IEnumerable> = + StoredUnionSamples.tagsTwice + |> Seq.map (fun twice -> + TestDataRow(twice, DisplayName = $"a union must not be described when %s{twice.Reason}") + ) + + /// Every way to set the serializer up: the ones of the layout tests and the ones that write a union differently. + static member ProfileRows : IEnumerable> = + seq { + yield! SerializerProfiles.all + yield! SerializerProfiles.unions + } + |> Seq.map (fun profile -> + TestDataRow( + profile, + DisplayName = $"the unions must be laid out as they are written by %s{profile.Name}" + ) + ) + + [] + member _.``The cases of a union must be laid out as the serializer writes them`` (profile : SerializerProfile) = + let found = disagreementsAlone profile + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"The layout should give every case a mark that the document of a value of the case has and the document of no other case, and every field the place of its value.\n%s{listed}" + ) + + [] + member _.``The cases of a union that a member holds must be laid out as the serializer writes them`` + (profile : SerializerProfile) + = + let found = disagreementsHeld profile + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"The layout should say of a union in a member what it says of the union alone, and nothing of a member that is not written.\n%s{listed}" + ) + + [] + member _.``The model of unions must be written in every way that the layout describes`` () = + // The tests above compare the layout with the documents they find. This one checks that the documents are of + // every kind: a model that the serializer wrote one way only would agree with a layout that knows one way. + let said = + seq { + yield! SerializerProfiles.all + yield! SerializerProfiles.unions + } + |> Seq.collect (fun profile -> + let layout = JsonLayout.ofSerializerOptions (profile.Create ()) + + seq { + for sample in StoredUnionSamples.all do + for case in FSharpType.GetUnionCases (sample.UnionType, true) do + match layout.UnionCaseEncoding (ValueNone, case) with + | UnionCaseEncoding.Written (mark, places) -> + match mark with + | UnionCaseMark.Tag (path, tag) -> + let steps = + path + |> Seq.map (fun step -> if step.IsProperty then "property" else "item") + |> String.concat ", " + + let kind = + match tag with + | UnionTag.String _ -> "a string" + | UnionTag.Number _ -> "a number" + | UnionTag.Boolean _ -> "a boolean" + + $"mark: %s{kind} at [%s{steps}]" + | UnionCaseMark.Property _ -> "mark: a property" + | UnionCaseMark.Null -> "mark: null" + | UnionCaseMark.Unmarked -> "mark: none" + + for place in places do + match place with + | UnionFieldPlace.Value path -> + let steps = + path + |> Seq.map (fun step -> if step.IsProperty then "property" else "item") + |> String.concat ", " + + $"field: a value at [%s{steps}]" + | UnionFieldPlace.Members path -> $"field: members at a path of %d{path.Length}" + | UnionCaseEncoding.NotDescribed -> "not described" + } + ) + |> Seq.distinct + |> Seq.sort + |> Seq.toArray + + CollectionAssert.AreEqual ( + [| + "field: a value at []" + "field: a value at [item]" + "field: a value at [property, item]" + "field: a value at [property, property]" + "field: a value at [property]" + "field: members at a path of 0" + "mark: a boolean at []" + "mark: a boolean at [item]" + "mark: a boolean at [property]" + "mark: a number at []" + "mark: a number at [item]" + "mark: a number at [property]" + "mark: a property" + "mark: a string at []" + "mark: a string at [item]" + "mark: a string at [property]" + "mark: none" + "mark: null" + "not described" + |], + said, + "The ways to set the serializer up should have the model written with every kind of mark and with a field at every kind of place." + ) + + [] + member _.``A part of the encoding in the attribute of a union must give way to the common encoding`` () = + // The options of the attribute say that they inherit the encoding, and FSharp.SystemTextJson then takes the + // whole encoding from the common options: the named fields that the attribute asks for are lost. + let options = (JsonFSharpOptions.Default().WithAllowOverride()).ToJsonSerializerOptions() + + let layout = JsonLayout.ofSerializerOptions options + + Assert.AreEqual( + "{\"kind\":\"Labelled\",\"data\":[\"label\",14]}", + JsonSerializer.Serialize (Labelled ("label", 14), options), + "The serializer should take the names of the attribute and the encoding of the common options, or the test checks nothing." + ) + + Assert.AreEqual( + "tag String \"Labelled\" at value[\"kind\"]; fields: value[\"data\"][0], value[\"data\"][1]", + described (layout.UnionCaseEncoding (ValueNone, caseNamed typeof "Labelled")), + "The layout follows the library: the names of the attribute, the encoding of the common options." + ) + + [] + member _.``A union that the serializer refuses must not be described`` () = + let options = SerializerProfiles.fsharpSystemTextJson.Create () + let layout = JsonLayout.ofSerializerOptions options + + Assert.Throws( + Action (fun () -> JsonSerializer.Serialize (Plain, options) |> ignore), + "FSharp.SystemTextJson should refuse a union with a case that has two attributes with names, or the test checks nothing." + ) + |> ignore + + Assert.AreEqual( + "not described", + described (layout.UnionCaseEncoding (ValueNone, caseNamed typeof "Plain")), + "No case of a union that the serializer cannot write is described." + ) + + [] + member _.``A union with two places for its tag must not be described`` () = + let options = + (JsonFSharpOptions + .Default() + .WithUnionEncoding( + JsonUnionEncoding.ExternalTag + ||| JsonUnionEncoding.InternalTag + )) + .ToJsonSerializerOptions() + + let layout = JsonLayout.ofSerializerOptions options + + Assert.Throws( + Action (fun () -> JsonSerializer.Serialize (Circle 3, options) |> ignore), + "FSharp.SystemTextJson should fail to write a union whose encoding has two places for the tag, or the test checks nothing." + ) + |> ignore + + Assert.AreEqual( + "not described", + described (layout.UnionCaseEncoding (ValueNone, caseNamed typeof "Circle")), + "A case that the serializer fails to write is not described." + ) + + [] + member _.``A union with a case that is written with the name of its tag twice must not be described`` + (twice : StoredTagTwice) + = + let options = twice.Settings.ToJsonSerializerOptions () + let layout = JsonLayout.ofSerializerOptions options + use document = JsonDocument.Parse (JsonSerializer.Serialize (twice.Value, options)) + + Assert.HasCount ( + 2, + document.RootElement.EnumerateObject () + |> Seq.where _.NameEquals(twice.TagName), + "FSharp.SystemTextJson should write the name of the tag twice for the case, or the test checks nothing." + ) + + let found = + describedCasesOf layout ValueNone typeof "a case has two properties of the name of the tag" + |> Seq.toArray + + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"A document of that case can hold the tag of another case in its second property, so no case can be told.\n%s{listed}" + ) + + [] + member _.``A union of a member with a converter of its own must not be described`` () = + let options = SerializerProfiles.fsharpSystemTextJson.Create () + let layout = JsonLayout.ofSerializerOptions options + let circle = caseNamed typeof "Circle" + let rect = caseNamed typeof "Rect" + + let memberOf (name : string) : DocumentMember voption = + ValueSome { + Holder = typeof + Member = nonNull (typeof.GetProperty name) + } + + let document = + JsonSerializer.SerializeToElement ( + StoredDrawing (Shape = Circle 3, Loud = Rect (4, "rect"), Hidden = Circle 5), + options + ) + + Assert.AreEqual( + "{\"Case\":\"RECT\",\"Fields\":[4,\"rect\"]}", + document.GetProperty("Loud").GetRawText(), + "The converter of the member should write the union with tags in capital letters, which the options do not say, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described (layout.UnionCaseEncoding (memberOf "Loud", rect)), + "Nothing shows the options that the converter of a member writes a union with, also when it is a converter of FSharp.SystemTextJson." + ) + + Assert.AreEqual( + described (layout.UnionCaseEncoding (ValueNone, circle)), + described (layout.UnionCaseEncoding (memberOf "Shape", circle)), + "A member without a converter of its own holds the union as it is written anywhere." + ) + + Assert.AreEqual( + "not described", + described (layout.UnionCaseEncoding (memberOf "Hidden", circle)), + "A member that the serializer never writes is not described: something else writes its property." + ) + + [] + member _.``An option must be described as a union only when it is written as one`` () = + let some = caseNamed typeof "Some" + let none = caseNamed typeof "None" + let unwrapped = JsonLayout.ofSerializerOptions (SerializerProfiles.fsharpSystemTextJson.Create ()) + let asUnion = SerializerProfiles.withoutUnwrappedOptions.Create () + let layout = JsonLayout.ofSerializerOptions asUnion + + Assert.AreEqual( + "not described", + described (unwrapped.UnionCaseEncoding (ValueNone, some)), + "An option that is written as its value is described by the question about a value that can be absent." + ) + + Assert.AreEqual( + "not described", + described (unwrapped.UnionCaseEncoding (ValueNone, caseNamed typeof> "Include")), + "A skippable value is always written as its value." + ) + + Assert.AreEqual( + "{\"Case\":\"Some\",\"Fields\":[1]}", + JsonSerializer.Serialize (Some 1, asUnion), + "The serializer should write the option as a union, or the test checks nothing." + ) + + Assert.AreEqual( + "tag String \"Some\" at value[\"Case\"]; fields: value[\"Fields\"][0]", + described (layout.UnionCaseEncoding (ValueNone, some)), + "An option that is written as a union is described as any union." + ) + + Assert.AreEqual( + "null; fields: ", + described (layout.UnionCaseEncoding (ValueNone, none)), + "The case without a value is the null of the option." + ) + + [] + member _.``A record in a case must not be described when it is not written as the record is by itself`` () = + let lent = caseNamed typeof "Lent" + let returned = caseNamed typeof "Returned" + + // The attribute of the union gives the options that unwrap the record, and the record is written with them. + let ofAttribute = (JsonFSharpOptions.Default().WithAllowOverride()).ToJsonSerializerOptions() + + let layout = JsonLayout.ofSerializerOptions ofAttribute + + Assert.AreEqual( + "{\"Case\":\"Lent\",\"Fields\":{\"Name\":\"lender\"}}", + JsonSerializer.Serialize (Lent { Name = "lender" }, ofAttribute), + "The serializer should write the members of the record in place of the fields, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described (layout.UnionCaseEncoding (ValueNone, lent)), + "The record is written with the options of the union, which are not the ones that the layout describes the record with. The encoding unwraps a case with one field as well, and the record goes first." + ) + + Assert.AreEqual( + "tag String \"Returned\" at value[\"Case\"]; fields: ", + described (layout.UnionCaseEncoding (ValueNone, returned)), + "A case without such a record is described." + ) + + // The converter of FSharp.SystemTextJson takes unions only, so System.Text.Json writes a record by itself. + let unionsOnly = + (JsonFSharpOptions.Default().WithTypes(JsonFSharpTypes.Unions).WithUnionUnwrapRecordCases()) + .ToJsonSerializerOptions(PropertyNamingPolicy = JsonNamingPolicy.CamelCase) + + Assert.AreEqual( + "{\"Case\":\"Signed\",\"Fields\":{\"name\":\"signer\"}}", + JsonSerializer.Serialize (Signed { Name = "signer" }, unionsOnly), + "The serializer should write the members of the record in place of the fields, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described ( + (JsonLayout.ofSerializerOptions unionsOnly).UnionCaseEncoding(ValueNone, caseNamed typeof "Signed") + ), + "The record by itself is written by System.Text.Json, so what the layout says of its members is not about the record in the case." + ) + + // A record that names the converter of the library in an attribute is written by a converter that the + // attribute makes, where no converter of the options takes records: without the naming policy of the options, + // which the union writes the members of the record with. + let signer = { SignedAs = "signer"; Alias = None } + let dealt = caseNamed typeof "Dealt" + + Assert.AreEqual( + "{\"SignedAs\":\"signer\",\"Alias\":null}", + JsonSerializer.Serialize (signer, unionsOnly), + "The converter of the attribute should write the record by itself, without the naming policy, or the test checks nothing." + ) + + Assert.AreEqual( + "{\"Case\":\"Dealt\",\"Fields\":{\"signedAs\":\"signer\",\"alias\":null}}", + JsonSerializer.Serialize (Dealt signer, unionsOnly), + "The union should write the members of the record with the naming policy of the options, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described ((JsonLayout.ofSerializerOptions unionsOnly).UnionCaseEncoding(ValueNone, dealt)), + "The layout names the members of the record as the converter of the attribute writes them, which is not how the case writes them." + ) + + // Another converter of the library among the options writes the records, with other options than the one + // that writes the unions. + let twoConverters = JsonSerializerOptions () + + twoConverters.Converters.Add ( + JsonFSharpConverter (JsonFSharpOptions.Default().WithTypes(JsonFSharpTypes.Unions).WithUnionUnwrapRecordCases()) + ) + + twoConverters.Converters.Add ( + JsonFSharpConverter (JsonFSharpOptions.Default().WithSkippableOptionFields SkippableOptionFields.Always) + ) + + Assert.AreEqual( + "{\"SignedAs\":\"signer\"}", + JsonSerializer.Serialize (signer, twoConverters), + "The second converter should write the record by itself and leave the option out, or the test checks nothing." + ) + + Assert.AreEqual( + "{\"Case\":\"Dealt\",\"Fields\":{\"SignedAs\":\"signer\",\"Alias\":null}}", + JsonSerializer.Serialize (Dealt signer, twoConverters), + "The first converter should write the members of the record in the case with its own options, which write the option, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described ((JsonLayout.ofSerializerOptions twoConverters).UnionCaseEncoding(ValueNone, dealt)), + "What the layout says of the members of the record is about the record as the second converter writes it." + ) + + [] + member _.``A union whose contract a resolver of the caller makes must not be described`` () = + let low = caseNamed typeof "Low" + + // The resolver makes the contract from the converter of FSharp.SystemTextJson for the union, which it has made + // with a naming policy that the options do not have. + let options = + JsonSerializerOptions ( + SerializerProfiles.fsharpSystemTextJson.Create (), + TypeInfoResolver = + StoredContractResolver(fun options -> + JsonMetadataServices.CreateValueInfo( + options, + nonNull (StoredLoudUnionConverterFactory().CreateConverter(typeof, options)) + ) + ) + ) + + Assert.AreEqual( + "{\"Case\":\"LOW\"}", + JsonSerializer.Serialize (Low, options), + "The resolver should have the union written with the converter that it made, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described ((JsonLayout.ofSerializerOptions options).UnionCaseEncoding(ValueNone, low)), + "The serializer did not make the contract of the union, so the converter among the options does not tell how the union is written." + ) + + [] + member _.``A union that a factory made of the one of FSharp.SystemTextJson writes must not be described`` () = + let options = JsonSerializerOptions () + options.Converters.Add (StoredQuietFactory ()) + + Assert.AreEqual( + "{\"Case\":\"Low\"}", + JsonSerializer.Serialize (Low, options), + "The factory should write the union, or the test checks nothing." + ) + + Assert.AreEqual( + "not described", + described ((JsonLayout.ofSerializerOptions options).UnionCaseEncoding(ValueNone, caseNamed typeof "Low")), + "Only the factory of FSharp.SystemTextJson itself shows the options that a union is written with." + ) + + [] + member _.``A layout must work out how a case is written once`` () = + let options = + (JsonFSharpOptions.Default().WithUnionTagNamingPolicy(StoredCountingNamingPolicy ())).ToJsonSerializerOptions() + + let layout = JsonLayout.ofSerializerOptions options + let low = caseNamed typeof "Low" + let first = layout.UnionCaseEncoding (ValueNone, low) + let spelledForFirst = StoredCountingNamingPolicy.Spelled + let second = layout.UnionCaseEncoding (ValueNone, low) + + Assert.AreEqual( + "tag String \"LOW\" at value[\"Case\"]; fields: ", + described first, + "The naming policy of the tags spells the name of the case." + ) + + Assert.AreEqual(described first, described second, "The answer is the same every time.") + + Assert.AreEqual( + spelledForFirst, + StoredCountingNamingPolicy.Spelled, + "The layout has the policy spell the name to find the answer, and remembers the answer: the policy spelled nothing for the second one." + ) diff --git a/tests/Cosmos.Quotations.Tests/JsonLayoutValueTests.fs b/tests/Cosmos.Quotations.Tests/JsonLayoutValueTests.fs new file mode 100644 index 00000000..0edccafa --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/JsonLayoutValueTests.fs @@ -0,0 +1,699 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Reflection +open System.Reflection.Emit +open System.Text.Json +open System.Text.Json.Serialization +open System.Text.Json.Serialization.Metadata +open Microsoft.VisualStudio.TestTools.UnitTesting +open FSharp.Reflection + +open FSharp.Azure.Cosmos +open FSharp.Azure.Cosmos.Quotations +open FSharp.Azure.Cosmos.Tests + +/// +/// What says about values that are no objects, compared +/// with what the serializer writes for them: every member of the model of values is written with every way to set the +/// serializer up, and the kind of JSON value that the document holds for it says what the layout should say. +/// +[] +type JsonLayoutValueTests () = + + /// The type arguments of the first of the generic types that a type is or implements. + static let argumentsOf (definitions : Type seq) (valueType : Type) : Type array voption = + seq { + valueType + yield! valueType.GetInterfaces () + } + |> Seq.tryPick (fun candidate -> + if + candidate.IsGenericType + && definitions + |> Seq.exists (fun definition -> Type.(=) (candidate.GetGenericTypeDefinition (), definition)) + then + ValueSome (candidate.GetGenericArguments ()) + else + ValueNone + ) + + /// The types of the keys and values of a map or a dictionary; no value for any other type. + static let keyAndValueOf (valueType : Type) : struct (Type * Type) voption = + argumentsOf + (seq { + typedefof> + typedefof> + typedefof> + }) + valueType + |> ValueOption.map (fun arguments -> struct (arguments[0], arguments[1])) + + /// The type of the items of a collection; no value for a text and for a type that is no collection. + static let elementOf (valueType : Type) : Type voption = + if Type.(=) (valueType, typeof) then + ValueNone + else + argumentsOf (Seq.singleton typedefof>) valueType + |> ValueOption.map (fun arguments -> arguments[0]) + + /// Whether a type is an enumeration or a nullable of one. + static let isEnumeration (valueType : Type) : bool = + match Nullable.GetUnderlyingType valueType with + | null -> valueType.IsEnum + | underlying -> underlying.IsEnum + + /// The names that the layout has for the members of a type, in the order of the names. + static let namesOf (layout : IJsonLayout) (holderType : Type) : string array = + seq { + for dataMember in ModelMembers.ofType holderType do + match layout.MemberName { Holder = holderType; Member = dataMember } with + | ValueSome name -> name + | ValueNone -> () + } + |> Seq.sort + |> Seq.toArray + + /// The names of the properties of a JSON object, in the order of the names. + static let propertiesOf (written : JsonElement) : string array = + written.EnumerateObject () + |> Seq.map _.Name + |> Seq.sort + |> Seq.toArray + + /// + /// Where what the layout says of a value differs from what the serializer wrote for it, as texts for a failure + /// message. The kind of the written JSON value says what the layout should say: a number or a string for an + /// enumeration, an array or an object for a tuple, an array for a collection, an object or an array for a map. + /// A value that was not written has no kind, and the layout should not describe it. + /// + static let disagreementsAbout + (layout : IJsonLayout) + (named : string) + (memberOfDocument : DocumentMember voption) + (valueType : Type) + (written : JsonElement) + : string seq = seq { + if isEnumeration valueType then + let expected = + match written.ValueKind with + | JsonValueKind.Number -> EnumEncoding.Number + | JsonValueKind.String -> EnumEncoding.String + | _ -> EnumEncoding.NotDescribed + + let said = layout.EnumEncoding (memberOfDocument, valueType) + + if said <> expected then + $"%s{named}: the layout says %A{said} of the enumeration, the document %A{expected}" + elif FSharpType.IsTuple valueType then + let expected = + match written.ValueKind with + | JsonValueKind.Array -> TupleEncoding.Array + | JsonValueKind.Object -> TupleEncoding.Object + | _ -> TupleEncoding.NotDescribed + + let said = layout.TupleEncoding (memberOfDocument, valueType) + + if said <> expected then + $"%s{named}: the layout says %A{said} of the tuple, the document %A{expected}" + elif expected.IsObject then + // The properties of the object are the members of the tuple that the layout names. + let writtenNames = propertiesOf written + let saidNames = namesOf layout valueType + + if saidNames <> writtenNames then + $"%s{named}: the layout names the items of the tuple %A{saidNames}, the document %A{writtenNames}" + else + match keyAndValueOf valueType, elementOf valueType with + | ValueSome (struct (key, value)), _ -> + let expected = + match written.ValueKind with + | JsonValueKind.Object -> MapEncoding.Object (key, value) + | JsonValueKind.Array -> MapEncoding.ArrayOfPairs (key, value) + | _ -> MapEncoding.NotDescribed + + let said = layout.MapEncoding (memberOfDocument, valueType) + + if said <> expected then + $"%s{named}: the layout says %A{said} of the map, the document %A{expected}" + | ValueNone, ValueSome element -> + let expected = + match written.ValueKind with + | JsonValueKind.Array -> CollectionEncoding.Array element + | _ -> CollectionEncoding.NotDescribed + + let said = layout.CollectionEncoding (memberOfDocument, valueType) + + if said <> expected then + $"%s{named}: the layout says %A{said} of the collection, the document %A{expected}" + | ValueNone, ValueNone -> () + } + + /// + /// Everything the layout says about the members of a sample that the document of the sample does not confirm; + /// empty when the layout is right. + /// + static let disagreements (profile : SerializerProfile) (sample : StoredValueSample) : string array = + let options = profile.Create () + let layout = JsonLayout.ofSerializerOptions options + let holderType = sample.Value.GetType () + let document = JsonSerializer.SerializeToElement (sample.Value, holderType, options) + + seq { + // Without this a layout that names no member would have nothing to disagree about. + let saidNames = namesOf layout holderType + let writtenNames = propertiesOf document + + if saidNames <> writtenNames then + $"The layout names the members %A{saidNames}, the document %A{writtenNames}" + + for dataMember in ModelMembers.ofType holderType do + let memberOfDocument = { Holder = holderType; Member = dataMember } + let memberType = ModelMembers.typeOf dataMember + + // A member that the document does not hold was not written: every member of a sample holds a value + // that no setting leaves out. It has the kind of no JSON value. + let written = + match layout.MemberName memberOfDocument with + | ValueSome name -> + match document.TryGetProperty name with + | true, written -> written + | false, _ -> JsonElement () + | ValueNone -> JsonElement () + + yield! disagreementsAbout layout dataMember.Name (ValueSome memberOfDocument) memberType written + + // The value under an option or a nullable is asked about as well, where the member is written as that + // value: the serializer writes the same for the member as for the value alone. + match ModelMembers.unwrapped (ModelMembers.valueOf sample.Value dataMember) memberType with + | ValueSome (struct (inner, innerType)) when not (Type.(=) (innerType, memberType)) -> + let alone = JsonSerializer.SerializeToElement (inner, innerType, options) + + if + written.ValueKind <> JsonValueKind.Undefined + && written.GetRawText () = alone.GetRawText () + then + yield! + disagreementsAbout + layout + $"what %s{dataMember.Name} holds" + (ValueSome memberOfDocument) + innerType + written + | _ -> () + } + |> Seq.toArray + + /// The kind of JSON value that a way to set the serializer up writes for a member of a sample; none when the + /// document does not hold the member. + static let kindOf (profile : SerializerProfile) (sample : StoredValueSample) (memberName : string) : JsonValueKind = + let options = profile.Create () + let holderType = sample.Value.GetType () + let document = JsonSerializer.SerializeToElement (sample.Value, holderType, options) + let layout = JsonLayout.ofSerializerOptions options + + match layout.MemberName { Holder = holderType; Member = nonNull (holderType.GetProperty memberName) } with + | ValueSome name -> + match document.TryGetProperty name with + | true, written -> written.ValueKind + | false, _ -> JsonValueKind.Undefined + | ValueNone -> JsonValueKind.Undefined + + /// A member of a type, as a layout is asked about it. + static let memberOf (holderType : Type) (name : string) : DocumentMember voption = + ValueSome { Holder = holderType; Member = nonNull (holderType.GetProperty name) } + + /// An enumeration without any value, which no F# source declares. + static let namelessEnumeration (assemblyName : string) : Type = + AssemblyBuilder + .DefineDynamicAssembly(AssemblyName assemblyName, AssemblyBuilderAccess.Run) + .DefineDynamicModule("Enumerations") + .DefineEnum("Nameless", TypeAttributes.Public, typeof) + .CreateType() + + /// Every type of the model of values with every way to set the serializer up. + static member SampleRows : IEnumerable> = seq { + for profile in SerializerProfiles.all do + for sample in StoredValueSamples.all do + TestDataRow( + struct (profile, sample), + DisplayName = $"the values of %s{sample.Name} must be laid out as they are written by %s{profile.Name}" + ) + } + + /// Every way to set the serializer up. + static member ProfileRows : IEnumerable> = + SerializerProfiles.all + |> Seq.map (fun profile -> + TestDataRow( + profile, + DisplayName = $"a value that is no member must be laid out as it is written by %s{profile.Name}" + ) + ) + + [] + member _.``The values of a type must be laid out as the serializer writes them`` + (profile : SerializerProfile, sample : StoredValueSample) + = + let found = disagreements profile sample + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"The layout should say of every member what the kind of its JSON value in the document shows, and nothing of a member that the document does not hold.\n%s{listed}" + ) + + [] + member _.``A value that is no member must be laid out as the serializer writes it`` (profile : SerializerProfile) = + let options = profile.Create () + let layout = JsonLayout.ofSerializerOptions options + + let found = + seq { + for struct (name, value, valueType) in StoredValueSamples.alone do + let written = JsonSerializer.SerializeToElement (value, valueType, options) + yield! disagreementsAbout layout name ValueNone valueType written + } + |> Seq.toArray + + let listed = String.Join ("\n", found) + + Assert.IsEmpty ( + found, + $"The layout should say of every value what the kind of the JSON value that is written for it shows.\n%s{listed}" + ) + + [] + member _.``The model of values must hold every kind of value in its documents`` () = + // The tests above compare the layout with the kind of JSON value they find. This one checks that they find + // every kind: a model that the serializer wrote one way only would agree with a layout that knows one way. + let plain = SerializerProfiles.systemTextJson + let fsharp = SerializerProfiles.fsharpSystemTextJson + let catalog = StoredValueSamples.catalog + let entry = StoredValueSamples.entry + + Assert.AreEqual(JsonValueKind.Number, kindOf plain catalog "Colour", "An enumeration is a number.") + + Assert.AreEqual( + JsonValueKind.String, + kindOf plain catalog "NamedColour", + "With the converter that its member names an enumeration is a string." + ) + + Assert.AreEqual( + JsonValueKind.String, + kindOf SerializerProfiles.enumerationsByName catalog "Colour", + "With a converter of the options an enumeration is a string." + ) + + Assert.AreEqual( + JsonValueKind.Number, + kindOf SerializerProfiles.enumerationsByName catalog "NumberedColour", + "The converter that a member names wins over the one of the options." + ) + + Assert.AreEqual( + JsonValueKind.String, + kindOf plain entry "NamedColour", + "System.Text.Json follows the converter that a field of a record names." + ) + + Assert.AreEqual( + JsonValueKind.Number, + kindOf fsharp entry "NamedColour", + "FSharp.SystemTextJson does not read the converter that a field of a record names." + ) + + Assert.AreEqual( + JsonValueKind.Object, + kindOf plain catalog "Pair", + "System.Text.Json writes a tuple as an object." + ) + + Assert.AreEqual( + JsonValueKind.Array, + kindOf fsharp catalog "Pair", + "FSharp.SystemTextJson writes a tuple as an array." + ) + + Assert.AreEqual(JsonValueKind.Array, kindOf plain catalog "Names", "A list is an array.") + Assert.AreEqual(JsonValueKind.String, kindOf plain catalog "Bytes", "An array of bytes is one string.") + + Assert.AreEqual( + JsonValueKind.Object, + kindOf plain catalog "ById", + "System.Text.Json writes a map as an object." + ) + + Assert.AreEqual( + JsonValueKind.Array, + kindOf fsharp catalog "ById", + "FSharp.SystemTextJson writes a map whose keys are no texts as an array of pairs." + ) + + Assert.AreEqual( + JsonValueKind.String, + kindOf plain StoredValueSamples.sealedCatalog "Pair", + "The converter of a member writes a tuple as a string." + ) + + Assert.AreEqual( + JsonValueKind.Undefined, + kindOf SerializerProfiles.ignoringReadOnlyProperties StoredValueSamples.readOnlyCatalog "Colour", + "A read-only member is not written when the options ignore such members." + ) + + Assert.AreEqual( + JsonValueKind.Array, + kindOf SerializerProfiles.ignoringReadOnlyProperties StoredValueSamples.readOnlyCatalog "Numbers", + "A read-only collection is written even then." + ) + + Assert.AreEqual( + JsonValueKind.Undefined, + kindOf fsharp entry "OtherColour", + "FSharp.SystemTextJson does not write a property of a record that is no field." + ) + + [] + member _.``A value of another kind must not be described`` () = + let layout = JsonLayout.ofSerializerOptions (SerializerProfiles.fsharpSystemTextJson.Create ()) + let plainLayout = JsonLayout.ofSerializerOptions (SerializerProfiles.systemTextJson.Create ()) + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (ValueNone, typeof), + "A number is no enumeration." + ) + + Assert.AreEqual( + TupleEncoding.NotDescribed, + layout.TupleEncoding (ValueNone, typeof), + "An array is no tuple, although it is written as one can be." + ) + + Assert.AreEqual( + TupleEncoding.NotDescribed, + plainLayout.TupleEncoding (ValueNone, typeof), + "A class is no tuple, although it is written as an object like one." + ) + + Assert.AreEqual( + CollectionEncoding.NotDescribed, + layout.CollectionEncoding (ValueNone, typeof), + "A text is no collection of its characters in a document." + ) + + Assert.AreEqual( + CollectionEncoding.NotDescribed, + layout.CollectionEncoding (ValueNone, typeof>), + "A map that is written as an object is no array." + ) + + Assert.AreEqual( + CollectionEncoding.NotDescribed, + plainLayout.CollectionEncoding (ValueNone, typeof>), + "Neither is a dictionary, of which the serializer writes the entries itself." + ) + + Assert.AreEqual( + MapEncoding.NotDescribed, + layout.MapEncoding (ValueNone, typeof), + "A list is no map." + ) + + [] + member _.``The extension data must not be described as a map`` () = + Assert.AreEqual( + MapEncoding.NotDescribed, + (JsonLayout.ofSerializerOptions (SerializerProfiles.systemTextJson.Create ())) + .MapEncoding(memberOf typeof "Extra", typeof>), + "Its entries are written as properties of the document itself, so no property of the document holds the dictionary." + ) + + [] + member _.``A layout must ask the serializer about a value once`` () = + let layout = JsonLayout.ofSerializerOptions (SerializerProfiles.systemTextJson.Create ()) + let counted = memberOf typeof + + // A question of every kind: each kind keeps its answers by itself. + let ask () = + struct (layout.EnumEncoding (counted "Colour", typeof), + layout.TupleEncoding (counted "Pair", typeof), + layout.CollectionEncoding (counted "Numbers", typeof), + layout.MapEncoding (counted "Lookup", typeof>)) + + let first = ask () + let madeForFirst = StoredCountingConverterFactory.Made + let second = ask () + + Assert.AreEqual( + struct (EnumEncoding.Number, + TupleEncoding.Object, + CollectionEncoding.Array typeof, + MapEncoding.Object (typeof, typeof)), + first, + "The factory of each member hands its value to the converter of the options, which writes it as any value of its type." + ) + + Assert.AreEqual( + first, + second, + "The answers are the same every time." + ) + + Assert.AreEqual( + madeForFirst, + StoredCountingConverterFactory.Made, + "The layout has the factory of each member make a converter to find an answer, and remembers the answers of every kind: the factory made no converter when the questions were asked again." + ) + + [] + member _.``An enumeration without a value that has a name must be a number`` () = + let options = JsonSerializerOptions () + options.Converters.Add (JsonStringEnumConverter ()) + + Assert.AreEqual( + EnumEncoding.Number, + (JsonLayout.ofSerializerOptions options).EnumEncoding(ValueNone, namelessEnumeration "JsonLayoutValueTests.Nameless"), + "A converter of names writes a value without a name as its number, and this enumeration has no other value." + ) + + [] + member _.``An enumeration must not be described when its converter refuses the value that is asked`` () = + // The converter of names can be made to refuse a value without a name, and this enumeration has no other one. + let options = JsonSerializerOptions () + options.Converters.Add (JsonStringEnumConverter (null, false)) + + Assert.AreEqual( + EnumEncoding.NotDescribed, + (JsonLayout.ofSerializerOptions options).EnumEncoding(ValueNone, namelessEnumeration "JsonLayoutValueTests.Refused"), + "The serializer writes no value of the enumeration, so there is nothing to describe." + ) + + // A converter of an application can refuse a value with the other exception that the serializer has for it. + let unsupporting = JsonSerializerOptions () + unsupporting.Converters.Add (StoredFirstColourConverter ()) + + Assert.Throws( + Action (fun () -> + JsonSerializer.Serialize (StoredColour.DarkBlue, unsupporting) + |> ignore + ), + "The converter should refuse the second value as not supported, or the test checks nothing." + ) + |> ignore + + Assert.AreEqual( + EnumEncoding.NotDescribed, + (JsonLayout.ofSerializerOptions unsupporting).EnumEncoding(ValueNone, typeof), + "The serializer does not write every value of the enumeration, so the layout cannot say how they are written." + ) + + [] + member _.``An enumeration must not be described when its converter writes its values in more than one way`` () = + let options = JsonSerializerOptions () + options.Converters.Add (StoredHalfNamedColourConverter ()) + + Assert.AreEqual( + EnumEncoding.NotDescribed, + (JsonLayout.ofSerializerOptions options).EnumEncoding(ValueNone, typeof), + "The converter writes the first value as its name and the other as its number, so a query can compare the values neither as numbers nor as texts." + ) + + [] + member _.``A nullable with a converter of its member must be described by the type under it as well`` () = + let layout = JsonLayout.ofSerializerOptions (SerializerProfiles.systemTextJson.Create ()) + let maybeNamed = memberOf typeof "MaybeNamedColour" + + Assert.AreEqual( + EnumEncoding.String, + layout.EnumEncoding (maybeNamed, typeof>), + "The converter of the member writes the name of the value." + ) + + Assert.AreEqual( + EnumEncoding.String, + layout.EnumEncoding (maybeNamed, typeof), + "The serializer has the converter of the member write the value under the nullable, so the layout describes that value the same way." + ) + + [] + member _.``A part of a value that a converter of its member writes must not be described`` () = + let layout = JsonLayout.ofSerializerOptions (SerializerProfiles.systemTextJson.Create ()) + let chosen = memberOf typeof "Chosen" + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (chosen, typeof), + "The converter of the member writes the option, and nothing shows what it writes for the enumeration under it." + ) + + Assert.AreEqual( + EnumEncoding.Number, + layout.EnumEncoding (memberOf typeof "Preferred", typeof), + "Without a converter of the member the enumeration under an option is written as any other one." + ) + + [] + member _.``A value that a converter of the options writes must not be described as what its type is`` () = + let options = SerializerProfiles.fsharpSystemTextJson.Create () + options.Converters.Insert (0, StoredAsTextConverter()) + options.Converters.Insert (0, StoredAsTextConverter()) + options.Converters.Insert (0, StoredAsTextConverter>()) + let layout = JsonLayout.ofSerializerOptions options + + Assert.AreEqual( + TupleEncoding.NotDescribed, + layout.TupleEncoding (ValueNone, typeof), + "The converter writes the tuple, in a way that the layout does not know." + ) + + Assert.AreEqual( + CollectionEncoding.NotDescribed, + layout.CollectionEncoding (ValueNone, typeof), + "The converter writes the list." + ) + + Assert.AreEqual( + MapEncoding.NotDescribed, + layout.MapEncoding (ValueNone, typeof>), + "The converter writes the map." + ) + + Assert.AreEqual( + TupleEncoding.Array, + layout.TupleEncoding (ValueNone, typeof), + "A tuple of another type is still written by FSharp.SystemTextJson." + ) + + [] + member _.``A tuple that a converter derived from the one of FSharp.SystemTextJson writes must not be described`` () = + let options = SerializerProfiles.fsharpSystemTextJson.Create () + options.Converters.Insert (0, StoredPairAsTextConverter ()) + let layout = JsonLayout.ofSerializerOptions options + + Assert.AreEqual( + "\"(1, a)\"", + JsonSerializer.Serialize ((1, "a"), options), + "The converter of the application should write the pair, and as text." + ) + + Assert.AreEqual( + TupleEncoding.NotDescribed, + layout.TupleEncoding (ValueNone, typeof), + "The class of the converter is the application's, whatever it is derived from, so nothing shows what it writes." + ) + + [] + member _.``A member of a type that another converter writes must not be described`` () = + let options = SerializerProfiles.fsharpSystemTextJson.Create () + options.Converters.Insert (0, StoredAsTextConverter()) + let layout = JsonLayout.ofSerializerOptions options + let field = memberOf typeof + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (field "Cover", typeof), + "The converter writes the album as a text, which has no members." + ) + + Assert.AreEqual( + TupleEncoding.NotDescribed, + layout.TupleEncoding (field "Size", typeof), + "So nothing is known about a tuple in it." + ) + + Assert.AreEqual( + CollectionEncoding.NotDescribed, + layout.CollectionEncoding (field "Tracks", typeof), + "Nor about a list in it." + ) + + Assert.AreEqual( + MapEncoding.NotDescribed, + layout.MapEncoding (field "Plays", typeof>), + "Nor about a map in it." + ) + + [] + member _.``A value must be described by the converter of its member when a resolver of the caller makes the contract of its type`` + () + = + // The resolver makes the contract of the enumeration itself, from a converter that writes text. + let options = + JsonSerializerOptions ( + TypeInfoResolver = + StoredContractResolver(fun options -> + JsonMetadataServices.CreateValueInfo(options, StoredAsTextConverter()) + ) + ) + + let layout = JsonLayout.ofSerializerOptions options + let written = JsonSerializer.SerializeToElement (StoredCatalog "catalog-1", options) + + Assert.AreEqual( + JsonValueKind.String, + written.GetProperty("Colour").ValueKind, + "The serializer should write a member without a converter of its own by the contract of the resolver, or the test checks nothing." + ) + + Assert.AreEqual( + JsonValueKind.Number, + written.GetProperty("NumberedColour").ValueKind, + "The serializer should write the member with the converter that the member names, whatever contract the resolver makes for its type, or the test checks nothing." + ) + + Assert.AreEqual( + EnumEncoding.String, + layout.EnumEncoding (memberOf typeof "Colour", typeof), + "A member without a converter of its own is described by the contract of the resolver." + ) + + Assert.AreEqual( + EnumEncoding.Number, + layout.EnumEncoding (memberOf typeof "NumberedColour", typeof), + "The converter of the member writes the value, and not the contract that the resolver makes for its type." + ) + + [] + member _.``A value must be described as the type that its member is read from is written`` () = + let options = JsonSerializerOptions () + options.Converters.Add (StoredTalkAsTextConverter ()) + let layout = JsonLayout.ofSerializerOptions options + + // The property as a quotation names it, also when it is read from the derived class. + let day = nonNull (typeof.GetProperty "Day") + + Assert.AreEqual( + EnumEncoding.String, + layout.EnumEncoding (ValueSome { Holder = typeof; Member = day }, typeof>), + "The serializer writes the class that declares the member as an object, and the member names a converter of names." + ) + + Assert.AreEqual( + EnumEncoding.NotDescribed, + layout.EnumEncoding (ValueSome { Holder = typeof; Member = day }, typeof>), + "A converter writes the class that inherits the member as a text, so no document of that class holds the value." + ) diff --git a/tests/Cosmos.Quotations.Tests/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/ModelMembers.fs b/tests/Cosmos.Quotations.Tests/ModelMembers.fs new file mode 100644 index 00000000..ee976511 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/ModelMembers.fs @@ -0,0 +1,75 @@ +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Reflection +open System.Text.Json.Serialization +open FSharp.Reflection + +/// +/// The members of a type of a test model that hold data, for the tests that compare what a layout says of every member +/// with a document that the serializer wrote. +/// +[] +module ModelMembers = + + /// The members of a type that hold data: its properties and fields, also the ones that are not public, without + /// what the compiler adds. + let ofType (holderType : Type) : MemberInfo seq = seq { + for found in + holderType.GetMembers ( + BindingFlags.Instance + ||| BindingFlags.Public + ||| BindingFlags.NonPublic + ) do + match found with + | :? PropertyInfo as property when property.GetIndexParameters().Length = 0 && property.CanRead -> found + // The field that the compiler makes for a property has a name that no source can write. + | :? FieldInfo as field when + not ( + field.Name.Contains ('@', StringComparison.Ordinal) + || field.Name.Contains ('<', StringComparison.Ordinal) + ) + -> + found + | _ -> () + } + + /// The value that a member holds in a value of the model. + let valueOf (holder : obj) (dataMember : MemberInfo) : objnull = + match dataMember with + | :? PropertyInfo as property -> property.GetValue holder + | :? FieldInfo as field -> field.GetValue holder + | other -> invalidOp $"The member is neither a property nor a field: %s{other.Name}" + + /// The type of the value of a member. + let typeOf (dataMember : MemberInfo) : Type = + match dataMember with + | :? PropertyInfo as property -> property.PropertyType + | :? FieldInfo as field -> field.FieldType + | other -> invalidOp $"The member is neither a property nor a field: %s{other.Name}" + + /// + /// The value under the outer layer of an optional value, with its type: what an option, a value option or a + /// skippable value holds, and a nullable or a reference itself. No value when the outer layer has none. + /// + let unwrapped (value : objnull) (valueType : Type) : struct (objnull * Type) voption = + let isMadeOf (definition : Type) = + valueType.IsGenericType + && Type.(=) (valueType.GetGenericTypeDefinition (), definition) + + if + isMadeOf typedefof<_ option> + || isMadeOf typedefof<_ voption> + || isMadeOf typedefof> + then + match value with + | null -> ValueNone + | value -> + match FSharpValue.GetUnionFields (value, valueType) with + | _, [| inner |] -> ValueSome (struct (inner, valueType.GetGenericArguments()[0])) + | _ -> ValueNone + else + match value, Nullable.GetUnderlyingType valueType with + | null, _ -> ValueNone + | value, null -> ValueSome (struct (value, valueType)) + | value, underlying -> ValueSome (struct (value, underlying)) 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..676091df --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/ParameterizerTests.fs @@ -0,0 +1,1079 @@ +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 + + 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) @@>) + } + |> 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 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/StoredModel.fs b/tests/Cosmos.Quotations.Tests/StoredModel.fs new file mode 100644 index 00000000..171cac47 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/StoredModel.fs @@ -0,0 +1,811 @@ +// The types that the tests of the JSON layout serialize. They are made for the layout: every way to name a member and +// every way to write a member without a value is here once. A test writes two values of each type with the real +// serializer, one with every optional member present and one with every optional member absent, and compares what +// the layout says with what was written. +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Text.Json +open System.Text.Json.Serialization +open System.Text.Json.Serialization.Metadata +open System.Threading +open FSharp.Reflection + +/// A converter that writes a collection of texts as one text, so that the serializer does not write its items. +type StoredJoinedTextsConverter () = + inherit JsonConverter () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : string array = + match reader.GetString () with + | null -> [||] + | joined -> joined.Split ',' + + /// + override _.Write (writer : Utf8JsonWriter, value : string array, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue (String.Join (',', value)) + +/// +/// A converter factory that hands a type to the converter that the options have for it anyway, as a factory of an +/// application does that only adds something around that converter. +/// +type StoredForwardingConverterFactory () = + inherit JsonConverterFactory () + + /// + override _.CanConvert (_ : Type) : bool = true + + /// + override _.CreateConverter (typeToConvert : Type, options : JsonSerializerOptions) : JsonConverter | null = + options.GetConverter typeToConvert + +/// The base of a class hierarchy, which System.Text.Json writes as objects whatever converters there are. +[] +type StoredDocument (id : string) = + + /// A property that is only read. + member _.Id = id + + /// A property that a derived class overrides. The name declared here belongs to this declaration only. + [] + abstract Tenant : string + + /// A property of the base class that can be set. + member val Note : string | null = null with get, set + + /// A property that a derived class overrides. The condition declared here belongs to this declaration only. + [] + abstract Remark : string | null with get, set + +/// A derived class with a member for every rule that System.Text.Json has for a property of an object. +type StoredPerson (id : string, name : string) = + inherit StoredDocument (id) + + /// A property named by the naming policy. + member _.Name = name + + /// The override: it declares no name of its own, so the serializer writes it under the name of the policy, + /// next to the property of the base class. + override _.Tenant = "tenant of " + id + + /// The override: it declares no condition of its own, so the serializer writes it as the options say, and not + /// as the declaration of the base class says. + override val Remark : string | null = null with get, set + + /// A collection that is only read. The serializer writes it also when it ignores read-only properties. + member _.Marks = [| "mark of " + id |] + + /// A collection that is only read and that a converter of the member writes as one text. To the serializer it is + /// no collection then, so the serializer leaves it out when it ignores read-only properties. + [)>] + member _.Labels = [| "label of " + id |] + + /// A collection that is only read, with a converter of the member that hands it to the converter of the options. + /// The serializer writes its items, so it is a collection: it is written also when read-only properties are + /// ignored. + [)>] + member _.Stamps = [| "stamp of " + id |] + + /// A property with a declared name. + [] + member val Nick : string | null = null with get, set + + /// A property that is never written. + [] + member val Secret : string | null = null with get, set + + /// A property that is never written and declares a name: it stands for a property that something else writes. + [] + member val Discriminator : string | null = null with get, set + + /// A reference that is left out when it is null, whatever the options say. + [] + member val Alias : string | null = null with get, set + + /// A nullable that is left out when it has no value, whatever the options say. + [] + member val Rank = Nullable() with get, set + + /// A reference that is always written, whatever the options say. + [] + member val Motto : string | null = null with get, set + + /// A nullable that follows the options. + member val Age = Nullable() with get, set + + /// An option that follows the options. + member val Choice : int option = None with get, set + + /// A value option that follows the options. + member val ValueChoice : int voption = ValueNone with get, set + + /// An option that is left out when it is null: an option without a value is null. + [] + member val ChoiceUnlessNull : int option = None with get, set + + /// A value option that is left out when it is the default value of its type, which is the one without a value. + [] + member val ValueChoiceUnlessDefault : int voption = ValueNone with get, set + + /// A property that is not public and is written because it says so. + [] + member val internal Hidden : string | null = null with get, set + + /// A field that is written because it says so. + [] + val mutable subject : string | null + + /// A field that is written only when the options include fields. + [] + val mutable plainField : string | null + + /// The properties of the document that no member stands for. + [] + member val Extra = Dictionary(StringComparer.Ordinal) with get, set + +/// A class that System.Text.Json refuses to write: a struct is never null, so it cannot be ignored when it is. +type StoredRefused (id : string) = + + /// A property that is only read. + member _.Id = id + + /// The member that the serializer refuses. + [] + member val Choice : int voption = ValueNone with get, set + +/// A class with the skippable values of FSharp.SystemTextJson, which System.Text.Json alone cannot write. +type StoredTask (id : string) = + + /// A property that is only read. + member _.Id = id + + /// A skippable value that follows the options. + member val Estimate : Skippable = Skip with get, set + + /// A skippable value that is left out when it is the default value of its type, which is the skipped one. + [] + member val Spent : Skippable = Skip with get, set + +/// A record that is the value of a field of another record. +type StoredAuthor = { + /// The name of the author. + Name : string +} + +/// A record with a field for every rule that FSharp.SystemTextJson has for a field of a record. +type StoredEntry = { + /// A field named by the naming policy. + Title : string + /// A field with a name declared the way System.Text.Json declares one. + [] + Body : string + /// A field with a name declared the way FSharp.SystemTextJson declares one, which System.Text.Json does not read. + [] + Tag : string + /// A field with a name that is given for a field of a union case. It is not the name of this field, which is + /// named by the naming policy. + [] + Subtitle : string + /// A field that is never written. + [] + Draft : string + /// A field that is never written and declares a name: it stands for a property that something else writes. + [] + Discriminator : string + /// A field that System.Text.Json leaves out when it is null and that FSharp.SystemTextJson never writes: it does + /// not read the condition. + [] + Dropped : string | null + /// A reference that can be null. + Comment : string | null + /// A nullable. + Count : Nullable + /// An option. + Choice : int option + /// A value option. + ValueChoice : int voption + /// An option of an option, whose inner absence cannot be told from the outer one when options are unwrapped. + Nested : string option option + /// A record, which FSharp.SystemTextJson writes as null when it is null, also when null values are ignored. + Author : StoredAuthor +} with + + /// A property that is not a field. FSharp.SystemTextJson writes it only when its options include properties. + member this.Summary = this.Title + "!" + + /// A property that is not a field and asks to be written. + [] + member this.Shout = this.Title.ToUpperInvariant () + + /// A property that is not a field and declares a name. Where FSharp.SystemTextJson does not write it, it stands + /// for a property that something else writes. + [] + member this.Initial = this.Title.Substring (0, 1) + + /// A property that is not public. FSharp.SystemTextJson looks at the public properties of a record only, so it + /// does not write this one, whatever its options say. + member internal this.Aside = "aside of " + this.Title + + /// A property that is not public and asks to be written. System.Text.Json writes it for an object, and + /// FSharp.SystemTextJson does not for a record. + [] + member internal this.Whisper = "whisper of " + this.Title + +/// A record with the skippable values of FSharp.SystemTextJson. +type StoredEstimate = { + /// A field that always has a value. + Title : string + /// A skippable value: it is left out when it is skipped, whatever the options say. + Estimate : Skippable + /// A skippable option: skipped, without a value or with one. + Remark : Skippable +} + +/// A generic record, which can be given options for all the types that are made of it. +type StoredBox<'Item> = { + /// What the box holds. + Item : 'Item + /// An option in a generic record. + Label : string option +} + +/// A struct record. +[] +type StoredPoint = { + /// A field that always has a value. + X : int + /// An option in a struct record. + Label : string option +} + +/// A converter that writes a point as text, which a layout cannot look into. +type StoredPointAsTextConverter () = + inherit JsonConverter () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : StoredPoint = + reader.Skip () + { X = 0; Label = None } + + /// + override _.Write (writer : Utf8JsonWriter, value : StoredPoint, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue $"%d{value.X}" + +/// A converter of strings that asks for null and writes a text for it, as a converter of an application can. +type StoredNullAsDashConverter () = + inherit JsonConverter () + + /// + override _.HandleNull = true + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : string | null = + match reader.GetString () with + | "-" -> null + | text -> text + + /// + override _.Write (writer : Utf8JsonWriter, value : string | null, _ : JsonSerializerOptions) : unit = + match value with + | null -> writer.WriteStringValue "-" + | value -> writer.WriteStringValue value + +/// A converter of strings that leaves null to the serializer, which writes it as null. +type StoredTextConverter () = + inherit JsonConverter () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : string | null = reader.GetString () + + /// + override _.Write (writer : Utf8JsonWriter, value : string | null, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue value + +/// A converter that writes a span as text. +type StoredSpanAsTextConverter () = + inherit JsonConverter () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : StoredSpan = + reader.Skip () + { From = 0; To = 0; Note = None } + + /// + override _.Write (writer : Utf8JsonWriter, value : StoredSpan, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue $"%d{value.From}-%d{value.To}" + +/// A record that names its converter in an attribute of the type. The serializer asks the converters of the options +/// first, so the named converter writes the record only when none of them takes it. +and [)>] StoredSpan = { + /// A field that always has a value. + From : int + /// Another one. + To : int + /// An option. + Note : string option +} + +/// +/// A converter factory of an application that is made of the one of FSharp.SystemTextJson and writes a point itself. +/// A layout that only asked for the factory would take the point for a record of FSharp.SystemTextJson. +/// +type StoredPointFactory () = + inherit JsonFSharpConverter (JsonFSharpOptions.Default ()) + + /// + override _.CreateConverter (typeToConvert : Type, options : JsonSerializerOptions) : JsonConverter = + if Type.(=) (typeToConvert, typeof) then + StoredPointAsTextConverter () + else + base.CreateConverter (typeToConvert, options) + +/// A class with members that name a converter of their own. +type StoredMeeting () = + + /// A nullable that the converter of the member writes. + [)>] + member val Day = Nullable() with get, set + + /// A reference whose converter leaves null to the serializer. + [)>] + member val Topic : string | null = null with get, set + + /// A reference whose converter asks for null and writes a text for it. + [)>] + member val Host : string | null = null with get, set + + /// An option whose converter is the one that the options have for it anyway. + [)>] + member val Alias : string option = None with get, set + + /// A reference that follows the options. + member val Room : string | null = null with get, set + +/// A class that inherits its members from one that System.Text.Json writes as an object. A test has a converter of +/// the options write it as text. +type StoredTalk () = + inherit StoredMeeting () + +/// A converter that writes a talk as text, which a layout cannot look into. +type StoredTalkAsTextConverter () = + inherit JsonConverter () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : StoredTalk = + reader.Skip () + StoredTalk () + + /// + override _.Write (writer : Utf8JsonWriter, _ : StoredTalk, _ : JsonSerializerOptions) : unit = writer.WriteStringValue "talk" + +/// Converters as an application can make them. +module StoredConverters = + + /// + /// The converter of FSharp.SystemTextJson for a record type, made with options that nothing shows to a layout: + /// every option is left out without a value, and the names are in snake case. + /// + let quietRecordConverter (recordType : Type) : JsonConverter | null = + let converterType = typedefof>.MakeGenericType recordType + + // The converter takes the options of the serializer when it is made, and these are not the ones of the caller. + let converter = + Activator.CreateInstance ( + converterType, + JsonSerializerOptions (PropertyNamingPolicy = JsonNamingPolicy.SnakeCaseLower), + JsonFSharpOptions.Default().WithSkippableOptionFields SkippableOptionFields.Always + ) + + match converter with + | :? JsonConverter as converter -> converter + | _ -> null + +/// +/// An attribute of an application that makes the converter of FSharp.SystemTextJson for a record itself, with options +/// that nothing shows to a layout: every option is left out without a value, and the names are in snake case. +/// +type StoredOwnConverterAttribute () = + inherit JsonConverterAttribute () + + /// + override _.CreateConverter (typeToConvert : Type) : JsonConverter | null = StoredConverters.quietRecordConverter typeToConvert + +/// +/// A converter factory of an application that is made of the one of FSharp.SystemTextJson and makes the converter of +/// every record itself, with options that it does not show: its own options are the default ones. +/// +type StoredQuietFactory () = + inherit JsonFSharpConverter (JsonFSharpOptions.Default ()) + + /// + override _.CreateConverter (typeToConvert : Type, options : JsonSerializerOptions) : JsonConverter = + if FSharpType.IsRecord typeToConvert then + nonNull (StoredConverters.quietRecordConverter typeToConvert) + else + base.CreateConverter (typeToConvert, options) + +/// +/// A resolver of contracts of an application that makes the contract of one type itself, without looking at the +/// converters of the options it is asked with. Every other contract is the work of the serializer. +/// +/// Makes the contract of the type for the options that ask. +type StoredContractResolver<'Value> (make : JsonSerializerOptions -> JsonTypeInfo) = + inherit DefaultJsonTypeInfoResolver () + + /// + override _.GetTypeInfo (valueType : Type, options : JsonSerializerOptions) : JsonTypeInfo = + if Type.(=) (valueType, typeof<'Value>) then + make options + else + base.GetTypeInfo (valueType, options) + +/// +/// A converter factory that counts how often it makes a converter, and hands the type to the converter that the +/// options have for it. A test sees by the count whether the layout asked the serializer again. Every type argument +/// has a count of its own: tests run at a time, and each test that counts names a type that no other test names. +/// +type StoredCountingConverterFactory<'Counted> () = + inherit JsonConverterFactory () + + static let mutable made = 0 + + /// How often the factories of this type have made a converter. + static member Made : int = Volatile.Read &made + + /// + override _.CanConvert (_ : Type) : bool = true + + /// + override _.CreateConverter (typeToConvert : Type, options : JsonSerializerOptions) : JsonConverter | null = + Interlocked.Increment &made |> ignore + options.GetConverter typeToConvert + +/// A class with a read-only collection whose converter factory counts its work. Only one test may ask about it. +type StoredCounted () = + + /// A property that can be set. + member val Title = "" with get, set + + /// The collection. + [>)>] + member _.Stamps = [| "stamp" |] + +/// +/// A converter factory that counts its work like the one above and holds every call at a gate until a test opens it, +/// so that the calls of several threads meet inside it. +/// +type StoredGatedConverterFactory () = + inherit JsonConverterFactory () + + static let mutable made = 0 + static let gate = new ManualResetEventSlim (true) + + /// How often the factories of this type have made a converter. + static member Made : int = Volatile.Read &made + + /// The gate that every call waits at; open until a test closes it. + static member Gate : ManualResetEventSlim = gate + + /// + override _.CanConvert (_ : Type) : bool = true + + /// + override _.CreateConverter (typeToConvert : Type, options : JsonSerializerOptions) : JsonConverter | null = + Interlocked.Increment &made |> ignore + gate.Wait () + options.GetConverter typeToConvert + +/// A class with a read-only collection whose converter factory waits at a gate. Only one test may ask about it. +type StoredGated () = + + /// A property that can be set. + member val Title = "" with get, set + + /// The collection. + [)>] + member _.Stamps = [| "stamp" |] + +/// A record whose converter an attribute of the application makes. +[] +type StoredCard = { + /// A field that always has a value. + FirstName : string + /// An option. + NickName : string option +} + +/// A union with a case that is represented by null. +[] +type StoredGrade = + /// The case that is null. + | Ungraded + /// A case with a value. + | Graded of points : int + +/// A union without such a case: a null of its type is no value of it. +type StoredMark = + /// A case without a value. + | Unmarked + /// A case with a value. + | Marked of points : int + +/// A union without any field. Where a case without fields is written as its tag alone, FSharp.SystemTextJson writes +/// such a union by a converter that cannot write a null. +type StoredSide = + /// One case. + | Front + /// Another case. + | Back + +/// A union that is written as the option it wraps. FSharp.SystemTextJson reads a value of it from a null, so a null +/// of its type is a value to the library. +type StoredNote = StoredNote of string option + +/// A union that is written as the text it wraps. The library reads no value of it from a null, unless its options +/// let a field of any type be null. +type StoredCaption = StoredCaption of string + +/// A union that is written as the number it wraps, which is null only where a field of any type may be. +type StoredNumber = StoredNumber of int + +/// A union that is written as the value option it wraps, which is null where options are written as their values. +type StoredCount = StoredCount of int voption + +/// A union that is written as the skippable value it wraps, which is null where the value under it can be. +type StoredHint = StoredHint of Skippable + +/// A union that is written as a skippable text, which cannot be null. +type StoredRemark = StoredRemark of Skippable + +/// +/// A union that is written as a value option of an option. Where value options are not written as their values, the +/// library still takes the value option for a skippable value when it always skips options, and the option under it +/// can be null. +/// +type StoredDeep = StoredDeep of string option voption + +/// A union that is written as another such union, which is null where that one is. +type StoredEnvelope = StoredEnvelope of StoredNote + +/// A union that is written as the unit value, which is null. +type StoredNothing = StoredNothing of unit + +/// A record with values of types of F# that can be null without being options. FSharp.SystemTextJson writes a null +/// of a record, a union or a tuple also where it leaves a null out, unless the null is a value to it: a case of the +/// union, or the null of a union that is written as the value it wraps where that value can be null. +type StoredPaper = { + /// A field that always has a value. + Heading : string + /// A union with a case that is null. + Grade : StoredGrade + /// A union without one. + Mark : StoredMark + /// A union that wraps an option. + Note : StoredNote + /// A union that wraps a text. + Caption : StoredCaption + /// A list, which is a union. + Lines : string list + /// A set, which is a class. + Tags : Set +} + +/// +/// A record that asks for options of its own in an attribute, with a union of one case. The options that the +/// attribute makes inherit the encoding of unions, so the common options say whether the union is written as the +/// value it wraps. +/// +[] +type StoredInherited = { + /// The union. + Wrapped : StoredNote + /// A field that always has a value. + Stated : string +} + +/// A class with a property of any type, which System.Text.Json writes as an object. +type StoredSlot<'Item> () = + + /// What the slot holds: nothing, unless it is set. + member val Item : 'Item = Unchecked.defaultof<'Item> with get, set + + /// A property that always has a value. + member val Count = 1 with get, set + +/// A record that asks for options of its own in an attribute. +[] +type StoredMarked = { + /// A field that always has a value. + Text : string + /// An option that the options of the attribute leave out without a value. + Note : string option + /// A reference that can be null. A converter that the attribute makes does not know that the options ignore null. + Remark : string | null +} + +/// +/// A type of the model as the tests write it: once with every optional member present, every member holding a value +/// that no other member holds, and once with every optional member absent. +/// +[] +type StoredSample = { + /// What the type is; the name of a test result holds it. + Name : string + /// The value with every optional member present. + Present : obj + /// The value with every optional member absent. + Absent : obj + /// Whether the value can be written without FSharp.SystemTextJson: it has no skippable value. + IsPlain : bool +} + +/// The values of the model. +module StoredSamples = + + /// The person with every member set. + let person = + let present = + StoredPerson ( + "id-1", + "name-1", + Note = "note-1", + Remark = "remark-1", + Nick = "nick-1", + Secret = "secret-1", + Discriminator = "person+v1", + Alias = "alias-1", + Rank = Nullable 11, + Motto = "motto-1", + Age = Nullable 12, + Choice = Some 13, + ValueChoice = ValueSome 14, + ChoiceUnlessNull = Some 15, + ValueChoiceUnlessDefault = ValueSome 17, + Hidden = "hidden-1" + ) + + present.subject <- "subject-1" + present.plainField <- "plain-1" + + { + Name = "a class" + Present = present + Absent = StoredPerson ("id-2", "name-2") + IsPlain = true + } + + /// The task with its skippable values. + let task = { + Name = "a class with skippable values" + Present = StoredTask ("id-1", Estimate = Include 21, Spent = Include 22) + Absent = StoredTask "id-2" + IsPlain = false + } + + /// The record. + let entry = { + Name = "a record" + Present = + ({ + Title = "title-1" + Body = "body-1" + Tag = "tag-1" + Subtitle = "subtitle-1" + Draft = "draft-1" + Discriminator = "entry+v1" + Dropped = "dropped-1" + Comment = "comment-1" + Count = Nullable 31 + Choice = Some 32 + ValueChoice = ValueSome 33 + Nested = Some (Some "nested-1") + Author = { Name = "author-1" } + } + : StoredEntry) + Absent = + ({ + Title = "title-2" + Body = "body-2" + Tag = "tag-2" + Subtitle = "subtitle-2" + Draft = "draft-2" + Discriminator = "entry+v1" + Dropped = null + Comment = null + Count = Nullable () + Choice = None + ValueChoice = ValueNone + Nested = None + Author = Unchecked.defaultof + } + : StoredEntry) + IsPlain = true + } + + /// The record with skippable values. + let estimate = { + Name = "a record with skippable values" + Present = ({ Title = "title-1"; Estimate = Include 41; Remark = Include (Some "remark-1") } : StoredEstimate) + Absent = ({ Title = "title-2"; Estimate = Skip; Remark = Skip } : StoredEstimate) + IsPlain = false + } + + /// The struct record. + let point = { + Name = "a struct record" + Present = ({ X = 51; Label = Some "label-1" } : StoredPoint) + Absent = ({ X = 52; Label = None } : StoredPoint) + IsPlain = true + } + + /// A generic record. + let box = { + Name = "a generic record" + Present = ({ Item = 71; Label = Some "label-1" } : StoredBox) + Absent = ({ Item = 72; Label = None } : StoredBox) + IsPlain = true + } + + /// An anonymous record. + let anonymous = { + Name = "an anonymous record" + Present = {| Title = "title-1"; Choice = Some 61; ValueChoice = ValueSome 62 |} + Absent = {| + Title = "title-2" + Choice = (None : int option) + ValueChoice = (ValueNone : int voption) + |} + IsPlain = true + } + + /// The record that asks for options of its own. + let marked = { + Name = "a record with options in an attribute" + Present = ({ Text = "text-1"; Note = Some "note-1"; Remark = "remark-1" } : StoredMarked) + Absent = ({ Text = "text-2"; Note = None; Remark = null } : StoredMarked) + IsPlain = true + } + + /// The record with the union that has a case that is null. + let paper = { + Name = "a record with values of types of F# that can be null" + Present = + ({ + Heading = "heading-1" + Grade = Graded 71 + Mark = Marked 72 + Note = StoredNote (Some "note-71") + Caption = StoredCaption "caption-71" + Lines = List.singleton "line-71" + Tags = Set.singleton "tag-71" + } + : StoredPaper) + Absent = + ({ + Heading = "heading-2" + Grade = Ungraded + Mark = Unchecked.defaultof + Note = Unchecked.defaultof + Caption = Unchecked.defaultof + Lines = Unchecked.defaultof + Tags = Unchecked.defaultof> + } + : StoredPaper) + IsPlain = false + } + + /// Every sample. + let all = + seq { + person + task + entry + estimate + point + box + anonymous + marked + paper + } + |> Collections.Immutable.ImmutableArray.CreateRange diff --git a/tests/Cosmos.Quotations.Tests/StoredUnions.fs b/tests/Cosmos.Quotations.Tests/StoredUnions.fs new file mode 100644 index 00000000..3cdbe56a --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/StoredUnions.fs @@ -0,0 +1,331 @@ +// The unions that the tests of the JSON layout serialize to see how a union is written. A test writes a value of +// every case with the real serializer and looks in the document for what the layout says: the mark of the case, which +// no value of another case may have, and the values of the fields at the places that the layout gives. +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Immutable +open System.Text.Json +open System.Text.Json.Serialization +open System.Threading +open FSharp.Reflection + +/// A union with a case for every way to declare a case and its fields. +type StoredShape = + /// A case without fields. + | Blank + /// A case with one field that the source names. + | Circle of radius : int + /// A case with two fields that the source does not name. + | Rect of int * string + /// A case whose one field is a record. + | Signed of StoredAuthor + /// A case with a name declared the way FSharp.SystemTextJson declares one, and a field that is an option. + | [] Polygon of sides : int * label : string option + /// A case that declares the name of a field, and whose fields are of one type. + | [] Pair of int * int + /// A case with a name declared the way System.Text.Json declares one. + | [] Point + +/// A union without any field, with cases that declare a number and a boolean in place of a name. +type StoredLevel = + /// A case that is written by its name. + | Low + /// A case that is written as a number. + | [] High + /// A case that is written as a boolean. + | [] Sure + +/// A union with one case that has one field, which is how an application wraps a value. +type StoredTicket = StoredTicket of Guid + +/// A union with one case that has several fields. +type StoredRange = StoredRange of first : int * last : int + +/// A union with one case that has no field. +type StoredToken = | StoredToken + +/// A struct union. +[] +type StoredSwitch = + /// A case without fields. + | On + /// A case with a field. + | Off of reason : string + +/// A union whose cases only its own module can use. +type StoredSecret = + private + | Code of code : int + | Unlocked + + /// A value of the case with a field. + static member OfCode (code : int) : StoredSecret = Code code + + /// The value of the case without a field. + static member Open : StoredSecret = Unlocked + +/// A generic union. +type StoredOutcome<'Value> = + /// A case with a field of the type argument. + | Fine of 'Value + /// A case with a field of a fixed type. + | Failed of reason : string + +/// A union with options of its own in an attribute that sets the whole encoding. +[] +type StoredStamp = + /// A case without fields. + | Unstamped + /// A case with fields. + | Stamped of text : string * size : int + +/// +/// A union with options of its own in an attribute that sets a part of the encoding. FSharp.SystemTextJson replaces +/// the whole encoding of such options by the common one, so the part is lost, and the names stay. +/// +[] +type StoredLabel = + /// A case without fields. + | Unlabelled + /// A case with fields. + | Labelled of text : string * size : int + +/// +/// A union with options of its own in an attribute that unwrap a record in a case, and a case with one field. A test +/// asks about it by itself: such a record is written with the options of the union, which the layout of the record +/// does not follow. +/// +[] +type StoredLoan = + /// A case whose one field is a record. + | Lent of StoredAuthor + /// A case without fields. + | Returned + +/// +/// A record that names the converter of FSharp.SystemTextJson in an attribute. Where no converter of the options +/// takes records, the attribute makes the converter of the record by itself, with options of the serializer of its +/// own. +/// +[] +type StoredSigner = { + /// A field that always has a value. + SignedAs : string + /// An option. + Alias : string option +} + +/// A union with a case whose one field is that record. +type StoredDeal = + /// The case with the record. + | Dealt of StoredSigner + /// A case without fields. + | Undealt + +/// A union that FSharp.SystemTextJson refuses: a case may have one attribute with its names, and this one has two. +type StoredTwice = + /// The case with two attributes. + | [] Named + /// A case as any other. + | Plain + +/// +/// A converter factory of an application that makes the converter of FSharp.SystemTextJson for a union itself, with a +/// naming policy for the tags that no options show: the tags are in capital letters. +/// +type StoredLoudUnionConverterFactory () = + inherit JsonConverterFactory () + + /// + override _.CanConvert (typeToConvert : Type) : bool = FSharpType.IsUnion (typeToConvert, true) + + /// + override _.CreateConverter (typeToConvert : Type, _ : JsonSerializerOptions) : JsonConverter | null = + JsonUnionConverter(JsonFSharpOptions.Default().WithUnionTagNamingPolicy JsonNamingPolicy.SnakeCaseUpper) + .CreateConverter(typeToConvert, JsonSerializerOptions ()) + +/// A record with a member of a union type, for every union: a test asks about the union as the value of the member. +type StoredHolder<'Union> = { + /// The union. + Held : 'Union +} + +/// A class with members of a union type. +type StoredDrawing () = + + /// A union that is written as the options say. + member val Shape = Blank with get, set + + /// A union with a converter of its own, which is the one of FSharp.SystemTextJson with options of its own. + [)>] + member val Loud = Blank with get, set + + /// A union that the serializer never writes. + [] + member val Hidden = Blank with get, set + +/// +/// A naming policy that counts how often it spells a name. A test sees by the count whether the layout worked an +/// answer out again. Only one test may use it. +/// +type StoredCountingNamingPolicy () = + inherit JsonNamingPolicy () + + static let mutable spelled = 0 + + /// How often the policies of this type have spelled a name. + static member Spelled : int = Volatile.Read &spelled + + /// + override _.ConvertName (name : string) : string = + Interlocked.Increment &spelled |> ignore + name.ToUpperInvariant () + +/// A way to have FSharp.SystemTextJson write the name of the tag of a union twice in one object. +type StoredTagTwice = { + /// What gives a case a second property of the name of the tag; the name of a test result holds it. + Reason : string + /// The name of the tag. + TagName : string + /// The options of FSharp.SystemTextJson that the union is written with. + Settings : JsonFSharpOptions + /// A value of a case that is written with the name twice. + Value : StoredShape +} + +/// The values of a union type that the tests write: one of every case at least. +[] +type StoredUnionSample = { + /// What the union is; the name of a test result holds it. + Name : string + /// The union type. + UnionType : Type + /// The values. + Values : ImmutableArray +} + +/// The values of the unions. +module StoredUnionSamples = + + /// A sample of a union type. + let private sample (name : string) (values : 'Union seq) : StoredUnionSample = { + Name = name + UnionType = typeof<'Union> + Values = values |> Seq.map box |> ImmutableArray.CreateRange + } + + /// Every way to have the name of the tag written twice: for the fields, and for one field among the tag. + let tagsTwice = + seq { + { + Reason = "the fields have the name of the tag" + TagName = "kind" + Settings = JsonFSharpOptions.Default().WithUnionTagName("kind").WithUnionFieldsName "kind" + Value = Rect (4, "rect") + } + { + Reason = "the one field that stands in place of the fields has the name of the tag" + TagName = "kind" + Settings = + JsonFSharpOptions.Default().WithUnionUnwrapSingleFieldCases().WithUnionTagName("kind").WithUnionFieldsName + "kind" + Value = Circle 3 + } + { + Reason = "a field has the name of the tag" + TagName = "radius" + Settings = JsonFSharpOptions.Default().WithUnionInternalTag().WithUnionNamedFields().WithUnionTagName "radius" + Value = Circle 3 + } + { + Reason = "a member of the record of a case has the name of the tag" + TagName = "Name" + Settings = + JsonFSharpOptions + .Default() + .WithUnionInternalTag() + .WithUnionNamedFields() + .WithUnionUnwrapRecordCases() + .WithUnionTagName + "Name" + Value = Signed { Name = "signer" } + } + } + |> ImmutableArray.CreateRange + + /// Every union that is described whenever the serializer writes it, with a value of every case. + let all = + seq { + sample + "a union with every kind of case" + (seq { + Blank + Circle 3 + Rect (4, "rect") + Signed { Name = "signer" } + Polygon (5, Some "label") + Polygon (6, None) + Pair (7, 8) + Point + }) + sample + "a union without fields" + (seq { + Low + High + Sure + }) + sample "a union that wraps a value" (Seq.singleton (StoredTicket (Guid "0f8fad5b-d9cb-469f-a165-70867728950e"))) + sample "a union with one case of several fields" (Seq.singleton (StoredRange (1, 9))) + sample "a union with one case without a field" (Seq.singleton StoredToken) + sample + "a union with a case that is null" + (seq { + Ungraded + Graded 2 + }) + sample + "a struct union" + (seq { + On + Off "reason" + }) + sample + "a union with private cases" + (seq { + StoredSecret.OfCode 11 + StoredSecret.Open + }) + sample + "a generic union of a number" + (seq { + Fine 12 + Failed "failure" + }) + sample + "a generic union of a text" + (seq { + Fine "fine" + Failed "failure" + }) + sample + "a union with the whole encoding in an attribute" + (seq { + Unstamped + Stamped ("stamp", 13) + }) + sample + "a union with a part of the encoding in an attribute" + (seq { + Unlabelled + Labelled ("label", 14) + }) + } + |> ImmutableArray.CreateRange diff --git a/tests/Cosmos.Quotations.Tests/StoredValues.fs b/tests/Cosmos.Quotations.Tests/StoredValues.fs new file mode 100644 index 00000000..7f6b3297 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/StoredValues.fs @@ -0,0 +1,473 @@ +// The types that the tests of the JSON layout serialize to see how values that are no objects are written: +// enumerations, tuples, collections and maps. A test writes a value of each type with the real serializer and +// compares what the layout says about every member with what was written. +namespace FSharp.Azure.Cosmos.Quotations.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open System.Text.Json +open System.Text.Json.Serialization + +/// An enumeration, which is written as a number or by the name of the value. +type StoredColour = + | Red = 1 + | DarkBlue = 2 + +/// An enumeration of flags: a value can be several of them at once. +[] +type StoredAccess = + | None = 0 + | Read = 1 + | Write = 2 + +/// A converter that writes any value as the text that the value gives of itself, which a layout cannot look into. +type StoredAsTextConverter<'Value> () = + inherit JsonConverter<'Value> () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : 'Value = + reader.Skip () + Unchecked.defaultof<'Value> + + /// + override _.Write (writer : Utf8JsonWriter, value : 'Value, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue (string (box value)) + +/// +/// A converter of a pair that is derived from the base class of the tuple converters of FSharp.SystemTextJson and +/// writes the pair as text all the same. The base class is public, so an application can have such a converter. +/// +type StoredPairAsTextConverter () = + inherit BaseJsonTupleConverter () + + /// + override _.ReadCore (reader : byref, _ : JsonSerializerOptions) : int * string = + reader.Skip () + (0, "") + + /// + override _.WriteCore (writer : Utf8JsonWriter, value : int * string, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue (string (box value)) + + /// + override _.Write (writer : Utf8JsonWriter, value : int * string, _ : JsonSerializerOptions) : unit = + writer.WriteStringValue (string (box value)) + +/// A converter factory that writes a value of any type as text; a member names it to be written that way. +type StoredAsTextConverterFactory () = + inherit JsonConverterFactory () + + /// + override _.CanConvert (_ : Type) : bool = true + + /// + override _.CreateConverter (typeToConvert : Type, _ : JsonSerializerOptions) : JsonConverter | null = + match Activator.CreateInstance (typedefof>.MakeGenericType typeToConvert) with + | :? JsonConverter as converter -> converter + | _ -> null + +/// +/// A converter of the enumeration of colours that writes the first value as its name and every other value as its +/// number, so that the enumeration is written in no one way. +/// +type StoredHalfNamedColourConverter () = + inherit JsonConverter () + + /// + override _.Read (reader : byref, _ : Type, _ : JsonSerializerOptions) : StoredColour = + match reader.TokenType with + | JsonTokenType.String -> StoredColour.Red + | _ -> enum(reader.GetInt32 ()) + + /// + override _.Write (writer : Utf8JsonWriter, value : StoredColour, _ : JsonSerializerOptions) : unit = + match value with + | StoredColour.Red -> writer.WriteStringValue (nameof StoredColour.Red) + | other -> writer.WriteNumberValue (int other) + +/// +/// A converter of the enumeration of colours that refuses every value but the first, as a converter does that was +/// written for the values of its day: with the exception that says that a value is not supported. +/// +type StoredFirstColourConverter () = + inherit JsonConverter () + + /// + override _.Read (_ : byref, _ : Type, _ : JsonSerializerOptions) : StoredColour = StoredColour.Red + + /// + override _.Write (writer : Utf8JsonWriter, value : StoredColour, _ : JsonSerializerOptions) : unit = + match value with + | StoredColour.Red -> writer.WriteStringValue (nameof StoredColour.Red) + | other -> raise (NotSupportedException $"The converter does not write the colour %d{int other}.") + +/// A class with a member for every kind of value that is no object. +type StoredCatalog (id : string) = + + /// A property that is only read. + member _.Id = id + + /// An enumeration that is written as the options say. + member val Colour = StoredColour.Red with get, set + + /// An enumeration with a converter of its own, which writes the name of the value. + [)>] + member val NamedColour = StoredColour.Red with get, set + + /// An enumeration with a converter of its own, which writes the number also when the options write names. + [>)>] + member val NumberedColour = StoredColour.Red with get, set + + /// Flags. + member val Access = StoredAccess.None with get, set + + /// A nullable enumeration. + member val MaybeColour = Nullable() with get, set + + /// A nullable enumeration with a converter of its own, which writes the value under the nullable. + [)>] + member val MaybeNamedColour = Nullable() with get, set + + /// An option of an enumeration: the value under the option is written as any enumeration is. + member val Preferred : StoredColour option = None with get, set + + /// A reference tuple. + member val Pair : int * string = (0, "") with get, set + + /// A struct tuple, of which System.Text.Json writes the fields only when the options include fields. + member val StructPair : struct (int * string) = struct (0, "") with get, set + + /// A tuple of eight items, which holds the eighth in a tuple of its own. + member val Octet : int * int * int * int * int * int * int * int = (0, 0, 0, 0, 0, 0, 0, 0) with get, set + + /// A value option of a tuple: the value under it is written as any tuple is. + member val Spare : (int * string) voption = ValueNone with get, set + + /// An array. + member val Numbers : int array = [||] with get, set + + /// An F# list. + member val Names : string list = [] with get, set + + /// An F# set. + member val Marks : Set = Set.empty with get, set + + /// An immutable array. + member val Codes : ImmutableArray = ImmutableArray.Empty with get, set + + /// A list that can change. + member val Items : ResizeArray = ResizeArray() with get, set + + /// A set that can change. + member val Keys : HashSet = HashSet(StringComparer.Ordinal) with get, set + + /// A sequence. + member val Sequence : int seq = Seq.empty with get, set + + /// An array of bytes, which is written as one text and not as an array. + member val Bytes : byte array = [||] with get, set + + /// An F# map with texts as keys. + member val Scores : Map = Map.empty with get, set + + /// An F# map with numbers as keys. + member val ById : Map = Map.empty with get, set + + /// A dictionary. + member val Lookup : Dictionary = Dictionary(StringComparer.Ordinal) with get, set + + /// A dictionary that is only read. + member val Index : IReadOnlyDictionary = Dictionary(StringComparer.Ordinal) with get, set + +/// A record with a field for every kind of value that is no object. +type StoredCatalogEntry = { + /// An enumeration that is written as the options say. + Colour : StoredColour + /// An enumeration whose field names a converter. System.Text.Json follows it, and FSharp.SystemTextJson does not + /// read it. + [)>] + NamedColour : StoredColour + /// An enumeration that is never written. + [] + Draft : StoredColour + /// Flags. + Access : StoredAccess + /// A nullable enumeration. + MaybeColour : Nullable + /// An option of an enumeration. + Preferred : StoredColour option + /// A reference tuple. + Pair : int * string + /// A struct tuple. + StructPair : struct (int * string) + /// A tuple of eight items. + Octet : int * int * int * int * int * int * int * int + /// A value option of a tuple. + Spare : (int * string) voption + /// An array. + Numbers : int array + /// An F# list. + Names : string list + /// An F# set. + Marks : Set + /// An immutable array. + Codes : ImmutableArray + /// An array of bytes. + Bytes : byte array + /// An F# map with texts as keys. + Scores : Map + /// An F# map with numbers as keys. + ById : Map + /// A dictionary. + Lookup : Dictionary +} with + + /// A property that is no field and says that it is written, with a converter of its own. + [)>] + member this.IncludedColour = this.Colour + + /// A property that is no field: FSharp.SystemTextJson writes it only when its options include such properties. + member this.OtherColour = this.Colour + +/// A class whose members name a converter that writes them as text, whatever they are. +type StoredSealedCatalog () = + + /// An enumeration that the converter of the member writes as a text. + [)>] + member val Colour = StoredColour.Red with get, set + + /// An option of an enumeration that the converter of the member writes: it writes the option, and nothing shows + /// what it writes for the enumeration under it. + [)>] + member val Chosen : StoredColour option = None with get, set + + /// A tuple that the converter of the member writes. + [)>] + member val Pair : int * string = (0, "") with get, set + + /// A list that the converter of the member writes. + [)>] + member val Names : string list = [] with get, set + + /// A map that the converter of the member writes. + [)>] + member val Scores : Map = Map.empty with get, set + +/// +/// A class whose members name a converter factory that hands them to the converter that the options have for their +/// types, so each is written as any value of its type is. +/// +type StoredForwardedCatalog () = + + /// An enumeration. + [)>] + member val Colour = StoredColour.Red with get, set + + /// A tuple. + [)>] + member val Pair : int * string = (0, "") with get, set + + /// An array. + [)>] + member val Numbers : int array = [||] with get, set + + /// An F# map. + [)>] + member val Scores : Map = Map.empty with get, set + + /// A dictionary. + [)>] + member val Lookup : Dictionary = Dictionary(StringComparer.Ordinal) with get, set + +/// +/// A class whose members are only read. With options that ignore read-only members the serializer writes none of them +/// but the collection and the dictionary. +/// +type StoredReadOnlyCatalog () = + + /// An enumeration. + member _.Colour = StoredColour.DarkBlue + + /// A tuple. + member _.Pair : int * string = (1, "one") + + /// An array. + member _.Numbers : int array = [| 1; 2 |] + + /// A dictionary. + member _.Lookup : IReadOnlyDictionary = + Dictionary(Seq.singleton (KeyValuePair ("a", 1)), StringComparer.Ordinal) + +/// +/// A class with a member for every kind of value that is no object, each with a converter factory that counts its +/// work. Only one test may ask about it. +/// +type StoredCountedCatalog () = + + /// An enumeration. + [>)>] + member val Colour = StoredColour.Red with get, set + + /// A tuple. + [>)>] + member val Pair : int * string = (0, "") with get, set + + /// An array. + [>)>] + member val Numbers : int array = [||] with get, set + + /// A dictionary. + [>)>] + member val Lookup : Dictionary = Dictionary(StringComparer.Ordinal) with get, set + +/// A record that a test has a converter of the options write as text, so that nothing is known about its fields. +type StoredAlbum = { + /// An enumeration. + Cover : StoredColour + /// A tuple. + Size : int * int + /// A list. + Tracks : string list + /// A map. + Plays : Map +} + +/// A value of the model of values, as the tests write it. +[] +type StoredValueSample = { + /// What the type is; the name of a test result holds it. + Name : string + /// The value, with something in every member. + Value : obj +} + +/// The values of the model of values. +module StoredValueSamples = + + /// A dictionary with one key, made anew for every member: a dictionary can change, so no two members share one. + let private lookup () : Dictionary = + Dictionary(Seq.singleton (KeyValuePair ("a", 1)), StringComparer.Ordinal) + + /// The class. + let catalog = { + Name = "a class with values that are no objects" + Value = + StoredCatalog ( + "id-1", + Colour = StoredColour.DarkBlue, + NamedColour = StoredColour.DarkBlue, + NumberedColour = StoredColour.DarkBlue, + Access = (StoredAccess.Read ||| StoredAccess.Write), + MaybeColour = Nullable StoredColour.Red, + MaybeNamedColour = Nullable StoredColour.Red, + Preferred = Some StoredColour.DarkBlue, + Pair = (1, "one"), + StructPair = struct (2, "two"), + Octet = (1, 2, 3, 4, 5, 6, 7, 8), + Spare = ValueSome (3, "three"), + Numbers = [| 1; 2 |], + Names = [ "a"; "b" ], + Marks = Set.ofArray [| 1; 2 |], + Codes = ImmutableArray.Create (1, 2), + Items = ResizeArray [| 1; 2 |], + Keys = HashSet([| "k" |], StringComparer.Ordinal), + Sequence = [| 1; 2 |], + Bytes = [| 1uy; 2uy |], + Scores = Map.ofArray [| ("a", 1) |], + ById = Map.ofArray [| (1, "a") |], + Lookup = lookup (), + Index = lookup () + ) + } + + /// The record. + let entry = { + Name = "a record with values that are no objects" + Value = + ({ + Colour = StoredColour.DarkBlue + NamedColour = StoredColour.DarkBlue + Draft = StoredColour.DarkBlue + Access = StoredAccess.Read ||| StoredAccess.Write + MaybeColour = Nullable StoredColour.Red + Preferred = Some StoredColour.DarkBlue + Pair = (1, "one") + StructPair = struct (2, "two") + Octet = (1, 2, 3, 4, 5, 6, 7, 8) + Spare = ValueSome (3, "three") + Numbers = [| 1; 2 |] + Names = [ "a"; "b" ] + Marks = Set.ofArray [| 1; 2 |] + Codes = ImmutableArray.Create (1, 2) + Bytes = [| 1uy; 2uy |] + Scores = Map.ofArray [| ("a", 1) |] + ById = Map.ofArray [| (1, "a") |] + Lookup = lookup () + } + : StoredCatalogEntry) + } + + /// The class whose members name a converter that writes text. + let sealedCatalog = { + Name = "a class whose members name a converter of their own" + Value = + StoredSealedCatalog ( + Colour = StoredColour.DarkBlue, + Chosen = Some StoredColour.DarkBlue, + Pair = (1, "one"), + Names = [ "a"; "b" ], + Scores = Map.ofArray [| ("a", 1) |] + ) + } + + /// The class whose members name a converter factory that hands them to the converter of the options. + let forwardedCatalog = { + Name = "a class whose members hand themselves to the converters of the options" + Value = + StoredForwardedCatalog ( + Colour = StoredColour.DarkBlue, + Pair = (1, "one"), + Numbers = [| 1; 2 |], + Scores = Map.ofArray [| ("a", 1) |], + Lookup = lookup () + ) + } + + /// The class whose members are only read. + let readOnlyCatalog = { + Name = "a class whose members are only read" + Value = StoredReadOnlyCatalog () + } + + /// Every sample. + let all = + seq { + catalog + entry + sealedCatalog + forwardedCatalog + readOnlyCatalog + } + |> ImmutableArray.CreateRange + + /// Values of every kind that are no members: what a collection or a tuple holds, with the type each is asked as. + let alone : ImmutableArray = + seq { + struct ("an enumeration", box StoredColour.DarkBlue, typeof) + struct ("flags", box (StoredAccess.Read ||| StoredAccess.Write), typeof) + struct ("a nullable enumeration", box StoredColour.Red, typeof>) + struct ("a pair", box (1, "one"), typeof) + struct ("a struct pair", box (struct (2, "two")), typeof) + struct ("a tuple of eight", box (1, 2, 3, 4, 5, 6, 7, 8), typeof) + struct ("an array", box [| 1; 2 |], typeof) + struct ("a list", box [ "a"; "b" ], typeof) + struct ("a set", box (Set.ofArray [| 1; 2 |]), typeof>) + struct ("an immutable array", box (ImmutableArray.Create (1, 2)), typeof>) + struct ("bytes", box [| 1uy; 2uy |], typeof) + struct ("a text", box "ab", typeof) + struct ("a map of texts", box (Map.ofArray [| ("a", 1) |]), typeof>) + struct ("a map of numbers", box (Map.ofArray [| (1, "a") |]), typeof>) + struct ("a dictionary", box (lookup ()), typeof>) + } + |> ImmutableArray.CreateRange diff --git a/tests/Cosmos.Quotations.Tests/TestCategories.fs b/tests/Cosmos.Quotations.Tests/TestCategories.fs new file mode 100644 index 00000000..1e8348c0 --- /dev/null +++ b/tests/Cosmos.Quotations.Tests/TestCategories.fs @@ -0,0 +1,49 @@ +// 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 layout that says how the serializer writes the members of a document: +/// . +/// +type JsonLayoutUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "JsonLayout" |] :> IList + +/// +/// Categorizes a unit test of the normalizer: +/// , +/// 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