|
(* |
|
Copyright © 2022 Mårten Rånge |
|
|
|
Permission is hereby granted, free of charge, to any person obtaining a copy |
|
of this software and associated documentation files (the “Software”), to deal |
|
in the Software without restriction, including without limitation the rights |
|
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell |
|
copies of the Software, and to permit persons to whom the Software is furnished |
|
to do so, subject to the following conditions: |
|
|
|
The above copyright notice and this permission notice shall be included in all |
|
copies or substantial portions of the Software. |
|
|
|
THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR |
|
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, |
|
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE |
|
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER |
|
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, |
|
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE |
|
SOFTWARE. |
|
*) |
|
|
|
// I wrote a blog about PushStream for F# advent 2022 |
|
// https://github.com/mrange/PushStream6 |
|
// I am appealed to them both because of their simplicity and performance |
|
// When generating values I need a place to my values after creation |
|
// PushStreams turn out to be very convenient |
|
type 'T PushStream = ('T -> bool) -> bool |
|
|
|
module PushStream = |
|
[<GeneralizableValue>] |
|
let empty<'T> : 'T PushStream = fun r -> true |
|
|
|
let inline map ([<InlineIfLambda>] m) ([<InlineIfLambda>] ps : 'T PushStream) : 'U PushStream = |
|
fun r -> |
|
ps (fun v -> r (m v)) |
|
|
|
let inline toResizeArray (capacity : int) ([<InlineIfLambda>] ps : 'T PushStream) : _ ResizeArray = |
|
let ra = ResizeArray capacity |
|
ps (fun v -> ra.Add v; true) |> ignore |
|
ra |
|
|
|
let inline toArray ([<InlineIfLambda>] ps : 'T PushStream) : _ array = |
|
let ra = toResizeArray 16 ps |
|
ra.ToArray () |
|
|
|
let inline (|>>) ([<InlineIfLambda>] a : _ -> _) ([<InlineIfLambda>] f : _ -> _) = f a |
|
|
|
module FsGen = |
|
module Details = |
|
open System |
|
open System.Reflection |
|
open System.Text |
|
|
|
open FSharp.Reflection |
|
|
|
type Gens = obj PushStream array |
|
type Ctor = obj array -> obj |
|
|
|
// All supported types have limited cardinality |
|
// Gens are used to generate nested values for tuple types |
|
// Ctor is used to create a tuple type |
|
// A record is a tuple with a bit of sugar on top |
|
type SupportedType = |
|
| FsUnion of (Gens*Ctor) array |
|
| FsRecord of Gens*Ctor |
|
| FsTuple of Gens*Ctor |
|
| FsUnit |
|
| Bool |
|
|
|
// Creates recursive receiver that populate vs |
|
// At each step receiver the v from previous receiver and store in vs |
|
// At the end of the receiver chain invoke the input receiver |
|
let rec mkReceiverLoop (gs : Gens) (ctor : Ctor) (r : obj -> bool) (vs : obj array) i = |
|
if i < gs.Length - 1 then |
|
let next = mkReceiverLoop gs ctor r vs (i + 1) |
|
let g = gs.[i + 1] |
|
fun v -> |
|
vs.[i] <- v |
|
g next |
|
else |
|
fun v -> |
|
vs.[i] <- v |
|
r (ctor vs) |
|
|
|
let produceAll (gs : Gens) (ctor : Ctor) (r : obj -> bool) = |
|
if gs.Length > 0 then |
|
let vs = Array.zeroCreate gs.Length |
|
let g = gs.[0] |
|
g (mkReceiverLoop gs ctor r vs 0) |
|
else |
|
r (ctor Array.empty) |
|
|
|
let rec genAll (p : string list) (t : Type) (remDepth : int) : obj PushStream = |
|
// In order to support recurisive types we need to limit to certain depth |
|
if remDepth <= 0 then |
|
fun r -> true |
|
else |
|
// Precompute the supported type so we don't have to do it for each value |
|
// The ctors can be cached to reduce memory footprint |
|
let st = |
|
#if DEBUG |
|
printfn "Analyzing type: %s" t.FullName |
|
#endif |
|
if t = typeof<bool> then |
|
Bool |
|
elif t = typeof<unit> then |
|
FsUnit |
|
elif FSharpType.IsUnion t then |
|
// Loop for all unit cases and create genarators and ctor for each case |
|
let mapper (case : UnionCaseInfo) = |
|
let ps = case.GetFields () |
|
let gs = |
|
ps |
|
|> Array.map (fun pi -> genAll ((sprintf "%s.%s" case.Name pi.Name)::p) pi.PropertyType (remDepth - 1)) |
|
(gs, FSharpValue.PreComputeUnionConstructor case) |
|
FSharpType.GetUnionCases t |
|
|> Array.map mapper |
|
|> FsUnion |
|
elif FSharpType.IsRecord t then |
|
// Create generators for each nested type and ctor for record |
|
let ps = FSharpType.GetRecordFields t |
|
let gs = |
|
ps |
|
|> Array.map (fun pi -> genAll ((sprintf "%s" pi.Name)::p) pi.PropertyType (remDepth - 1)) |
|
(gs, FSharpValue.PreComputeRecordConstructor t) |> FsRecord |
|
elif FSharpType.IsTuple t then |
|
// Create generators for each nested type and ctor for tuple |
|
let ts = FSharpType.GetTupleElements t |
|
let gs = |
|
ts |
|
|> Array.mapi (fun ii ti -> genAll ((sprintf "_%i" ii)::p) ti (remDepth - 1)) |
|
(gs, FSharpValue.PreComputeTupleConstructor t) |> FsTuple |
|
else |
|
// If the type isn't supported try to tell the programmer the |
|
// path of the type in the type tree |
|
let sb = StringBuilder 16 |
|
let rec loop (sb : StringBuilder) (pp : string list) = |
|
match pp with |
|
| [] -> sb.Append "$" |> ignore |
|
| h::t -> |
|
loop sb t |
|
sb.Append '.' |> ignore |
|
sb.Append h |> ignore |
|
loop sb p |
|
failwithf "Unsupported type %s @ %s" t.Name <| sb.ToString () |
|
fun r -> |
|
// r is a receiver of values so start producing values |
|
match st with |
|
| FsUnion cases -> |
|
// Loop from each union case and generator all values |
|
// for each |
|
let rec cloop (cases : (Gens*Ctor) array) ci = |
|
if ci < cases.Length then |
|
let gs, ctor = cases.[ci] |
|
produceAll gs ctor r && cloop cases (ci + 1) |
|
else |
|
true |
|
cloop cases 0 |
|
| FsRecord (gs, ctor) -> |
|
produceAll gs ctor r |
|
| FsTuple (gs, ctor) -> |
|
let vs = Array.zeroCreate gs.Length |
|
produceAll gs ctor r |
|
| FsUnit -> |
|
// Produce a unit value |
|
r () |
|
| Bool -> |
|
// Produce true and false |
|
r false && r true |
|
|
|
open PushStream |
|
// Produces a PushStream that will generate all values for 'T |
|
// Cache this PushStream in order to avoid iterating over the type |
|
// multiple times |
|
let inline genAll<'T> (maxDepth : int) : 'T PushStream = |
|
Details.genAll List.empty typeof<'T> maxDepth |
|
|>> map (fun (v : obj) -> v :?> 'T) |
|
|
|
module TestJson = |
|
// A test model for a Json parser perhaps? |
|
type ArrayValue<'T> = |
|
| Empty |
|
| One of 'T |
|
| Two of 'T*'T |
|
|
|
type NumberValue = |
|
| Zero |
|
| One |
|
| PI |
|
|
|
type StringValue = |
|
| Empty |
|
| Hello |
|
| Escaped |
|
|
|
type JsonValue = |
|
| NullValue |
|
| StringValue of StringValue |
|
| NumberValue of NumberValue |
|
| BooleanValue of bool |
|
| ArrayValue of JsonValue ArrayValue |
|
| ObjectValue of (StringValue*JsonValue) ArrayValue |
|
|
|
open PushStream |
|
let jsonValueGen = FsGen.genAll<JsonValue> 6 |
|
let genAll () = jsonValueGen |>> toArray |
|
open System.Diagnostics |
|
|
|
[<EntryPoint>] |
|
let main argv = |
|
let sw = Stopwatch.StartNew () |
|
let vs = TestJson.genAll () |
|
sw.Stop () |
|
printfn "%A" vs.Length |
|
printfn "Distinct: %A" (vs |> Array.distinct |> Array.length) |
|
printfn "Took %d ms" sw.ElapsedMilliseconds |
|
printfn "%A" (vs |> Array.truncate 10) |
|
0 |