F# Gen All

genall.fs

type 'T PushStream = ('T -> bool) -> bool

// 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
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 SupportedType =
      | FsUnion   of (UnionCaseInfo*PropertyInfo array*obj PushStream array*(obj array -> obj)) array
      | FsRecord  of PropertyInfo array*obj PushStream array*(obj array -> obj)
      | FsTuple   of Type array*obj PushStream array*(obj array -> obj)
      | FsUnit
      | Bool

    let rec genAll (p : string list) (t : Type) (remDepth : int) : obj PushStream =
      if remDepth <= 0 then
        fun r -> true
      else
        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
            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))
              (case, ps, gs, FSharpValue.PreComputeUnionConstructor case)
            FSharpType.GetUnionCases t
              |> Array.map mapper
              |> FsUnion
          elif FSharpType.IsRecord t then
            let ps = FSharpType.GetRecordFields t
            let gs =
              ps 
              |> Array.map (fun pi -> genAll ((sprintf "%s" pi.Name)::p) pi.PropertyType (remDepth - 1))

            (ps, gs, FSharpValue.PreComputeRecordConstructor t) |> FsRecord
          elif FSharpType.IsTuple t then
            let ts = FSharpType.GetTupleElements t
            let gs : obj PushStream array = 
              ts 
              |> Array.mapi (fun ii ti -> genAll ((sprintf "_%i" ii)::p) ti (remDepth - 1))
            (ts, gs, FSharpValue.PreComputeTupleConstructor t) |> FsTuple
          else
            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 ->
          match st with
          | FsUnion cases ->
            let rec cloop (cases : (UnionCaseInfo*PropertyInfo array*obj PushStream array*(obj array -> obj)) array) ci =
              if ci < cases.Length then
                let case, _, gs, ctor = cases.[ci]
                let vs                = Array.zeroCreate gs.Length
                let rec loop t (gs : obj PushStream array) (vs : obj array) i =
                  if i < gs.Length then
                    let g = gs.[i]
                    g (fun v -> vs.[i] <- v; loop t gs vs (i + 1))
                  else
                    let v = ctor vs
                    (r v)
                loop t gs vs 0 && cloop cases (ci + 1)
              else
                true
            cloop cases 0
          | FsRecord (_, gs, ctor) ->
            let vs = Array.zeroCreate gs.Length
            let rec loop t (gs : obj PushStream array) (vs : obj array) i =
              if i < gs.Length then
                let g = gs.[i]
                g (fun v -> vs.[i] <- v; loop t gs vs (i + 1))
              else
                let v = ctor vs
                (r v)
            loop t gs vs 0
          | FsTuple (_, gs, ctor) ->
            let vs = Array.zeroCreate gs.Length
            let rec loop t (gs : obj PushStream array) (vs : obj array) i =
              if i < gs.Length then
                let g = gs.[i]
                g (fun v -> vs.[i] <- v; loop t gs vs (i + 1))
              else
                let v = ctor vs
                r v
            loop t gs vs 0
          | FsUnit ->
            r ()
          | Bool ->
            r false && r true

  open PushStream
  let inline genAll<'T> (maxDepth : int) : 'T PushStream =
    Details.genAll List.empty typeof<'T> maxDepth
      |>> map (fun (v : obj) -> v :?> 'T)

module TestJson =
  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 genAll () = 
    FsGen.genAll<JsonValue> 6 
      |>> 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