Add auto-generator

.gitignore

@@ -48,4 +48,7 @@ Thumbs.db
 # Paket - dependency management for .NET and Mono projects
 .paket/paket.bootstrapper.run
 .paket/paket.exe
-paket-files
+paket-files
+
+# Visual Studio cache/options directory
+.vs/

src/Hedgehog.Experimental/Gen.fs

@@ -1,96 +1,98 @@
-module Hedgehog.Gen
+namespace Hedgehog
 
-    open Hedgehog.Gen
+open TypeShape
+open System
 
+module GenX =
     /// Shortcut for Gen.list (Range.exponential lower upper).
     let eList (lower : int) (upper : int) : (Gen<'a> -> Gen<List<'a>>) =
-        list (Range.exponential lower upper)
+        Gen.list (Range.exponential lower upper)
 
     /// Shortcut for Gen.list (Range.linear lower upper).
     let lList (lower : int) (upper : int) : (Gen<'a> -> Gen<List<'a>>) =
-        list (Range.linear lower upper)
+        Gen.list (Range.linear lower upper)
 
     /// Shortcut for Gen.list (Range.constant lower upper).
     let cList (lower : int) (upper : int) : (Gen<'a> -> Gen<List<'a>>) =
-        list (Range.constant lower upper)
+        Gen.list (Range.constant lower upper)
 
     /// Shortcut for Gen.string (Range.exponential lower upper).
     let eString (lower : int) (upper : int) : (Gen<char> -> Gen<string>) =
-        string (Range.exponential lower upper)
+        Gen.string (Range.exponential lower upper)
 
     /// Shortcut for Gen.string (Range.linear lower upper).
     let lString (lower : int) (upper : int) : (Gen<char> -> Gen<string>) =
-        string (Range.linear lower upper)
+        Gen.string (Range.linear lower upper)
 
     /// Shortcut for Gen.string (Range.constant lower upper).
     let cString (lower : int) (upper : int) : (Gen<char> -> Gen<string>) =
-        string (Range.constant lower upper)
+        Gen.string (Range.constant lower upper)
 
     /// Generates null part of the time.
     let withNull (g : Gen<'a>) : Gen<'a> =
-        g |> option |> map (fun xOpt ->
+        g |> Gen.option |> Gen.map (fun xOpt ->
             match xOpt with Some x -> x | None -> null)
 
     /// Generates a value that is not null.
     let noNull (g : Gen<'a>) : Gen<'a> =
-        g |> filter (not << isNull)
+        g |> Gen.filter (not << isNull)
 
     /// Generates a value that is not equal to another value.
     let notEqualTo (other : 'a) : (Gen<'a> -> Gen<'a>) =
-        filter ((<>) other)
+        Gen.filter ((<>) other)
 
     /// Generates a value that is not equal to another option-wrapped value.
     let notEqualToOpt (other : 'a option) : (Gen<'a> -> Gen<'a>) =
-        filter (fun x -> match other with Some o -> x <> o | None -> true)
+        Gen.filter (fun x -> match other with Some o -> x <> o | None -> true)
 
     /// Generates a value that is not contained in the specified list.
     let notIn (list: 'a list) (g : Gen<'a>) : Gen<'a> =
-        g |> filter (fun x -> not <| List.contains x list)
+        g |> Gen.filter (fun x -> not <| List.contains x list)
 
     /// Generates a list that does not contain the specified element.
     /// Shortcut for Gen.filter (not << List.contains x)
     let notContains (x: 'a) : (Gen<'a list> -> Gen<'a list>) =
-      filter (not << List.contains x)
+      Gen.filter (not << List.contains x)
 
     /// Inserts the given element at a random place in the list
     let addElement (x : 'a) (g : Gen<'a list>) : Gen<'a list> =
         gen {
-          let! xs = g
-          let! i = integral (Range.constant 0 xs.Length)
-          let l1, l2 = xs |> List.splitAt i
-          return List.concat [l1; [x]; l2]
+            let! xs = g
+            let! i = Gen.integral (Range.constant 0 xs.Length)
+            let l1, l2 = xs |> List.splitAt i
+            return List.concat [l1; [x]; l2]
         }
 
     /// Generates a 2-tuple with sorted elements.
     let sorted2 (g : Gen<'a * 'a>) : Gen<'a * 'a> =
-        g |> map (fun (x1, x2) ->
+        g |> Gen.map (fun (x1, x2) ->
             let l = [x1; x2] |> List.sort
             (l.Item 0, l.Item 1))
 
     /// Generates a 3-tuple with sorted elements.
     let sorted3 (g : Gen<'a * 'a * 'a>) : Gen<'a * 'a * 'a> =
-        g |> map (fun (x1, x2, x3) ->
+        g |> Gen.map (fun (x1, x2, x3) ->
             let l = [x1; x2; x3] |> List.sort
             (l.Item 0, l.Item 1, l.Item 2))
 
     /// Generates a 4-tuple with sorted elements.
     let sorted4 (g : Gen<'a * 'a * 'a * 'a>) : Gen<'a * 'a * 'a * 'a> =
-        g |> map (fun (x1, x2, x3, x4) ->
+        g |> Gen.map (fun (x1, x2, x3, x4) ->
             let l = [x1; x2; x3; x4] |> List.sort
             (l.Item 0, l.Item 1, l.Item 2, l.Item 3))
 
     /// Generates a 2-tuple with distinct elements.
     let distinct2 (g : Gen<'a * 'a>) : Gen<'a * 'a> =
-        g |> filter (fun (x1, x2) -> x1 <> x2)
+        g |> Gen.filter (fun (x1, x2) -> x1 <> x2)
 
     /// Generates a 3-tuple with distinct elements.
     let distinct3 (g : Gen<'a * 'a * 'a>) : Gen<'a * 'a * 'a> =
-        g |> filter (fun (x1, x2, x3) ->
+        g |> Gen.filter (fun (x1, x2, x3) ->
             [x1; x2; x3] |> List.distinct = [x1; x2; x3])
 
     /// Generates a 4-tuple with distinct elements.
     let distinct4 (g : Gen<'a * 'a * 'a * 'a>) : Gen<'a * 'a * 'a * 'a> =
-        g |> filter (fun (x1, x2, x3, x4) ->
+        g |> Gen.filter (fun (x1, x2, x3, x4) ->
             [x1; x2; x3; x4] |> List.distinct = [x1; x2; x3; x4])
 
     /// Generates a 2-tuple with strictly increasing elements.
@@ -108,18 +110,24 @@
     /// Generates a tuple of datetimes where the range determines the minimum
     /// and maximum number of days apart. Positive numbers means the datetimes
     /// will be in increasing order, and vice versa.
-    let dateInterval (dayRange : Range<int>)
-            : Gen<System.DateTime * System.DateTime> =
+    let dateInterval (dayRange : Range<int>) : Gen<DateTime * DateTime> =
         gen {
-            let tickRange =
+            let! ticksApart =
                 dayRange
-                |> Range.map (fun days ->
-                    Operators.int64 days * System.TimeSpan.TicksPerDay)
-            let! ticksApart = integral tickRange
-            let! dt1 = dateTime |> filter (fun dt ->
-                dt.Ticks + ticksApart > System.DateTime.MinValue.Ticks
-                && dt.Ticks + ticksApart < System.DateTime.MaxValue.Ticks)
-            let dt2 = dt1.AddTicks ticksApart
+                |> Range.map
+                    (fun days ->
+                        Operators.int64 days * TimeSpan.TicksPerDay)
+                |> Gen.integral
+
+            let! dt1 =
+                Gen.dateTime
+                |> Gen.filter
+                    (fun dt ->
+                        dt.Ticks + ticksApart > DateTime.MinValue.Ticks
+                     && dt.Ticks + ticksApart < DateTime.MaxValue.Ticks)
+            let dt2 =
+                dt1.AddTicks ticksApart
+
             return dt1, dt2
         }
 
@@ -134,7 +142,7 @@
         gen {
             let! inputs = inpGen
             let inputsDistinct = inputs |> List.distinct
-            let! outputs = outGen |> list (Range.singleton inputsDistinct.Length)
+            let! outputs = outGen |> Gen.list (Range.singleton inputsDistinct.Length)
             let inOutMap = List.zip inputsDistinct outputs |> Map.ofList
             return inputs, (fun x -> inOutMap.Item x)
         }
@@ -150,17 +158,188 @@
     let withDistinctMapTo (outGen : Gen<'b>) (inpGen : Gen<'a list>)
             : Gen<'a list * ('a -> 'b)> =
         gen {
-          let rec distinctOutGen (xs : 'b list) (length : int) : Gen<'b list> =
-              gen {
-                  if xs.Length = length then return xs
-                  else
-                      let! x = outGen |> notIn xs
-                      return! distinctOutGen (x::xs) length
-              }
-
-          let! inputs = inpGen
-          let inputsDistinct = inputs |> List.distinct
-          let! outputs = distinctOutGen [] inputsDistinct.Length
-          let inOutMap = List.zip inputsDistinct outputs |> Map.ofList
-          return inputs, (fun x -> inOutMap.Item x)
+            let rec distinctOutGen (xs : 'b list) (length : int) : Gen<'b list> =
+                gen {
+                    if xs.Length = length then return xs
+                    else
+                        let! x = outGen |> notIn xs
+                        return! distinctOutGen (x::xs) length
+                }
+
+            let! inputs = inpGen
+            let inputsDistinct = inputs |> List.distinct
+            let! outputs = distinctOutGen [] inputsDistinct.Length
+            let inOutMap = List.zip inputsDistinct outputs |> Map.ofList
+            return inputs, (fun x -> inOutMap.Item x)
+        }
+
+    [<CLIMutable; Struct>]
+    type AutoGenConfig =
+      {Byte: Gen<byte>
+       Int16: Gen<int16>
+       Int: Gen<int>
+       Int64: Gen<int64>
+       Double: Gen<double>
+       Decimal: Gen<decimal>
+       Bool: Gen<bool>
+       Guid: Gen<System.Guid>
+       Char: Gen<System.Char>
+       DateTime: Gen<System.DateTime>
+       String: Gen<System.String>
+       DateTimeOffset: Gen<System.DateTimeOffset>
+       SeqRange: Range<int> // range for lists, arrays, etc.
+       }
+
+    let defaults =
+      {Byte = Gen.byte <| Range.exponentialBounded()
+       Int16 = Gen.int16 <| Range.exponentialBounded()
+       Int = Gen.int <| Range.exponentialBounded()
+       Int64 = Gen.int64 <| Range.exponentialBounded()
+       Double = Gen.double <| Range.exponentialBounded()
+       Decimal = Gen.double <| Range.exponentialBounded() |> Gen.map decimal
+       Bool = Gen.bool
+       Guid = Gen.guid
+       Char = Gen.latin1
+       DateTime = Gen.dateTime
+       String = Gen.string (Range.linear 0 50) Gen.latin1
+       DateTimeOffset = Gen.dateTime |> Gen.map System.DateTimeOffset
+       SeqRange = Range.exponential 0 50}
+
+    let rec auto'<'T> (config:AutoGenConfig) : Gen<'T> =
+      let wrap (t : Gen<'a>) =
+        unbox<Gen<'T>> t
+
+      let mkRandomMember (shape : IShapeWriteMember<'DeclaringType>) = 
+        shape.Accept {
+          new IWriteMemberVisitor<'DeclaringType, Gen<'DeclaringType -> 'DeclaringType>> with
+            member __.Visit(shape : ShapeWriteMember<'DeclaringType, 'Field>) = 
+              let rf = auto'<'Field>(config)
+              gen { let! f = rf
+                    return fun dt -> shape.Inject dt f } }
+
+      match TypeShape.Create<'T>() with
+      | Shape.Byte -> wrap config.Byte
+      | Shape.Int16 -> wrap config.Int16
+      | Shape.Int32 -> wrap config.Int
+      | Shape.Int64 -> wrap config.Int64
+
+      | Shape.Double -> wrap config.Double
+      | Shape.Decimal -> wrap config.Decimal
+
+      | Shape.Bool -> wrap config.Bool
+      | Shape.Guid -> wrap config.Guid
+      | Shape.Char -> wrap config.Char
+      | Shape.DateTime -> wrap config.DateTime
+
+      | Shape.Unit -> wrap (Gen.constant ())
+
+      | Shape.String -> wrap config.String
+      | Shape.DateTimeOffset -> wrap config.DateTimeOffset
+
+      | Shape.FSharpOption s -> 
+        s.Accept {
+          new IFSharpOptionVisitor<Gen<'T>> with
+            member __.Visit<'t>() = 
+              auto'<'t> config |> Gen.option |> wrap }
+
+      | Shape.Array s when s.Rank = 1 -> 
+        s.Accept { 
+          new IArrayVisitor<Gen<'T>> with
+            member __.Visit<'t> _ = 
+              auto'<'t> config |> Gen.array config.SeqRange |> wrap }
+
+      | Shape.Array _ -> 
+        raise (System.NotSupportedException("Can only generate arrays of rank 1"))
+
+      | Shape.FSharpList s -> 
+        s.Accept {
+          new IFSharpListVisitor<Gen<'T>> with
+            member __.Visit<'t> () = 
+              auto'<'t> config |> Gen.list config.SeqRange |> wrap }
+
+      | Shape.FSharpSet s -> 
+        s.Accept {
+          new IFSharpSetVisitor<Gen<'T>> with
+            member __.Visit<'t when 't : comparison> () = 
+              auto'<'t list> config 
+              |> Gen.map Set.ofList 
+              |> wrap }
+
+      | Shape.FSharpMap s -> 
+        s.Accept {
+          new IFSharpMapVisitor<Gen<'T>> with
+            member __.Visit<'k, 'v when 'k : comparison> () = 
+              auto'<('k * 'v) list> config
+              |> Gen.map Map.ofList
+              |> wrap }
+
+      | Shape.Tuple (:? ShapeTuple<'T> as shape) -> 
+        let eGens =
+          shape.Elements
+          |> Array.map mkRandomMember
+
+        gen { 
+          let mutable target = shape.CreateUninitialized ()
+          for eg in eGens do
+            let! u = eg
+            target <- u target
+          return target
         }
+
+      | Shape.FSharpRecord (:? ShapeFSharpRecord<'T> as shape) -> 
+        let fieldGen =
+          shape.Fields
+          |> Array.map mkRandomMember
+
+        gen { 
+          let mutable target = shape.CreateUninitialized ()
+          for eg in fieldGen do
+            let! u = eg
+            target <- u target
+          return target
+        }
+
+      | Shape.FSharpUnion (:? ShapeFSharpUnion<'T> as shape) -> 
+        let caseFieldGen =
+          shape.UnionCases
+          |> Array.map (fun uc -> uc.Fields |> Array.map mkRandomMember)
+
+        gen { 
+          let! tag = Gen.integral <| Range.constant 0 (caseFieldGen.Length - 1)
+          let mutable u = shape.UnionCases.[tag].CreateUninitialized ()
+          for f in caseFieldGen.[tag] do
+            let! uf = f
+            u <- uf u
+          return u
+        }
+
+      | Shape.CliMutable (:? ShapeCliMutable<'T> as shape) -> 
+        let propGen = shape.Properties |> Array.map mkRandomMember
+        gen { 
+          let mutable target = shape.CreateUninitialized ()
+          for ep in propGen do
+            let! up = ep
+            target <- up target
+          return target
+        }
+
+      | Shape.Poco (:? ShapePoco<'T> as shape) -> 
+        let bestCtor = 
+          shape.Constructors
+          |> Seq.filter  (fun c -> c.IsPublic)
+          |> Seq.sortBy  (fun c -> c.Arity)
+          |> Seq.tryHead
+
+        match bestCtor with
+        | None -> failwithf "Class %O lacking an appropriate ctor" typeof<'T>
+        | Some ctor -> 
+          ctor.Accept {
+            new IConstructorVisitor<'T, Gen<'T>> with
+              member __.Visit<'CtorParams> (ctor : ShapeConstructor<'T, 'CtorParams>) = 
+                let paramGen = auto'<'CtorParams> (config)
+                gen { let! args = paramGen
+                  return ctor.Invoke args } }
+
+      | _ -> raise (System.NotSupportedException ())
+
+    let auto<'T>() = auto'<'T>(defaults)