wip

ocaml/loadgen/freer.ml

@@ -76,9 +76,25 @@ struct
         let dynamic = Dynamic (op, map, f) in
         Blocked (dynamic, Fun.id)
 
-  let ( >>> ) a b =
-    (* TODO: optimized version from speculative.ml *)
-    a >>= fun () -> b
+  let ( >>> ) : unit t -> 'a t -> 'a t =
+   fun ignorable next ->
+    match (ignorable, next) with
+    | Pure (), _ ->
+        next
+    | Blocked (ops, f), Pure x ->
+        Blocked
+          ( ops
+          , fun result ->
+              let () = f result in
+              x
+          )
+    | Blocked (opsf, f), Blocked (opsnext, nextf) ->
+        Blocked
+          ( opsf <@@> opsnext
+          , fun (x, y) ->
+              let () = f x in
+              nextf y
+          )
 
   let ( >> ) m n = ignore <$> m >>> n
 

ocaml/loadgen/test_categories.ml

@@ -57,41 +57,43 @@ end
 module Check (G : Free) = struct
   let gen = Crowbar.(map [G.Gen.gen G.Gen.gena] G.lift)
 
-  let run t = Rresult.R.(t >>= fun t -> Rresult.R.trap_exn G.run t)
+  let wrap run t = Rresult.R.(t >>= fun t -> Rresult.R.trap_exn run t)
 
-  let check_eq x y =
+  let run2 t = t |> G.run |> G.run
+
+
+  let run = G.run
+
+  let check_eq run x y =
     (* TODO: wrap with result *)
-    let x' = run x and y' = run y in
+    let x' = wrap run x and y' = wrap run y in
     let pp = Rresult.R.pp ~ok:G.Gen.pp ~error:Rresult.R.pp_exn_trap in
     let error (`Exn_trap (e1, _)) (`Exn_trap (e2, _)) = e1 = e2 in
     let eq = Result.equal ~ok:G.Gen.eq ~error in
     Crowbar.check_eq ~pp ~eq x' y'
 
-  let check1 ~name f1 f2 =
+  let check1 run ~name f1 f2 =
     Crowbar.(add_test ~name [gen]) @@ fun x ->
-    check_eq (Rresult.R.trap_exn f1 x) (Rresult.R.trap_exn f2 x)
+    check_eq run (Rresult.R.trap_exn f1 x) (Rresult.R.trap_exn f2 x)
 
-  let check2 ~name f1 f2 =
+  let check2 run ~name f1 f2 =
     Crowbar.(add_test ~name [gen; gen]) @@ fun x y ->
-    check_eq
+    check_eq run
       (() |> Rresult.R.trap_exn @@ fun () -> f1 x y)
       (() |> Rresult.R.trap_exn @@ fun () -> f2 x y)
 
-  (*let check3 ~name f1 f2 =
-    Crowbar.(add_test ~name [gen; gen; gen]) @@ fun x y z ->
-    check_eq (() |> Rresult.R.trap_exn @@ fun () -> f1 x y z) (() |> Rresult.R.trap_exn @@ fun () -> f2 x y z)*)
 end
 
 let ( <.> ) f g x = f (g x)
 
 let test_functor (module F : Free) =
   let module C = Check (F) in
-  C.check1 ~name:"fmap id" (F.fmap Fun.id) Fun.id ;
+  C.check1 C.run ~name:"fmap id" (F.fmap Fun.id) Fun.id ;
 
   (* usually checking the 2nd law is redundant, but exceptions can make a difference *)
   let g = Fun.id in
   let h _ = failwith "Test" in
-  C.check1 ~name:"fmap (g . h) = (fmap g) . (fmap h)"
+  C.check1 C.run ~name:"fmap (g . h) = (fmap g) . (fmap h)"
     (F.fmap @@ g <.> h)
     (F.fmap g <.> F.fmap h)
 
@@ -105,7 +107,7 @@ let test_functor_ops (module F : FunctorOps) =
      (fun x y -> x <$ y)
      (fun x y -> (fmap <.> const) x y) ; *)
   let g = Fun.id in
-  C.check1 ~name:"fmap and (<$>)" (fun x -> fmap g x) (fun x -> g <$> x)
+  C.check1 C.run ~name:"fmap and (<$>)" (fun x -> fmap g x) (fun x -> g <$> x)
 
 module type Applicative = sig
   include Free
@@ -129,24 +131,37 @@ let test_applicative (module A : Applicative) =
   let module C = Check (A) in
   test_functor (module A) ;
   let open A in
-  let _f = Fun.id in
+  let f = Fun.id in
   (* TODO: some more interesting 'f', perhaps provided by Gen itself,
        or if we use these in functor form then we have more control over what ['a] can be
      ? *)
   let g = Fun.id in
-  C.check1 ~name:"identity: pure id <*> v = v"
+  C.check1 C.run ~name:"identity: pure id <*> v = v"
     (fun v -> A.pure Fun.id <*> v)
     Fun.id ;
-  (* C.check1 ~name:"homomorphism: pure f <*> pure x = pure (f x)"
-     (fun x -> pure f <*> pure x)
-     (fun x -> pure (f x)) ; *)
-  (*C.check2 ~name:"interchange: u <*> pure y = pure (\\f -> f y) <*> u"
-      (fun u y -> u <*> pure y)
-      (fun u y -> pure (fun f -> f y) <*> u) ;
-    C.check3 ~name:"composition: u <*> (v <*> w) = pure (.) <*> u <*> v <*> w"
-      (fun u v w -> u <*> (v <*> w))
-      (fun u v w -> pure ( <.> ) <*> u <*> v <*> w) ;*)
-  C.check1 ~name:"relation to functor: fmap g x = pure g <*> x"
+  C.check1 C.run2 ~name:"homomorphism: pure f <*> pure x = pure (f x)"
+    (fun x -> pure f <*> pure x)
+    (fun x -> pure (f x)) ;
+  C.check1 C.run2 ~name:"interchange: u <*> pure y = pure (\\f -> f y) <*> u"
+    (fun y ->
+      let u = pure f in
+      u <*> pure y
+    )
+    (fun y ->
+      let u = pure f in
+      pure (fun f -> f y) <*> u
+    ) ;
+  C.check1 C.run
+    ~name:"composition: u <*> (v <*> w) = pure (.) <*> u <*> v <*> w"
+    (fun w ->
+      let u = pure f and v = pure f in
+      u <*> (v <*> w)
+    )
+    (fun w ->
+      let u = pure f and v = pure f in
+      pure ( <.> ) <*> u <*> v <*> w
+    ) ;
+  C.check1 C.run ~name:"relation to functor: fmap g x = pure g <*> x"
     (fun x -> fmap g x)
     (fun x -> pure g <*> x)
 
@@ -156,10 +171,10 @@ let test_applicative_ops (module A : ApplicativeOps) =
   test_functor_ops (module A) ;
   let open A in
   let liftA2 f x y = f <$> x <*> y in
-  C.check2 ~name:"a1 (*>) a2 = (id <$ a1) <*> a2"
+  C.check2 C.run ~name:"a1 (*>) a2 = (id <$ a1) <*> a2"
     (fun a1 a2 -> a1 *> a2)
     (fun a1 a2 -> Fun.id <$ a1 <*> a2) ;
-  C.check2 ~name:"(<*) = liftA2 const"
+  C.check2 C.run ~name:"(<*) = liftA2 const"
     (fun x y -> x <* y)
     (fun x y -> liftA2 const x y)
 
@@ -184,29 +199,29 @@ let test_monad (module M : Monad) =
   let join x = x >>= Fun.id in
   let k = return in
   let h = return in
-  let _f = Fun.id in
+  let f = Fun.id in
   (*  C.check1 ~name:"return a >>= k = k a" (fun a -> return a >>= k) (fun a -> k a) ; *)
-  C.check1 ~name:"m >>= return = m" (fun m -> m >>= return) (fun m -> m) ;
-  C.check1 ~name:"m >>= (fun x -> k x >>= h) = (m >>= k) >>= h"
+  C.check1 C.run ~name:"m >>= return = m" (fun m -> m >>= return) (fun m -> m) ;
+  C.check1 C.run ~name:"m >>= (fun x -> k x >>= h) = (m >>= k) >>= h"
     (fun m -> m >>= fun x -> k x >>= h)
     (fun m -> m >>= k >>= h) ;
-  (*C.check1 ~name:"join . fmap join = join . join"
-    (join <.> fmap join)
-    (join <.> join) ;*)
-  C.check1 ~name:"join . fmap return = join . return = id"
+  C.check1 C.run2 ~name:"join . fmap join = join . join"
+    (fun x -> pure (pure (pure x)) |> (join <.> fmap join))
+    (fun x -> pure (pure (pure x)) |> (join <.> join)) ;
+  C.check1 C.run ~name:"join . fmap return = join . return = id"
     (join <.> fmap return)
     (join <.> return) ;
-  C.check1 ~name:"join . return = id" (join <.> return) Fun.id
-(* C.check1 ~name:"return . f = fmap f . return" (return <.> f)
-   (fmap f <.> return)*)
-(*C.check1 ~name:"join . fmap (fmap f) = fmap f . join"
-  (join <.> fmap (fmap f))
-  (fmap f <.> join)*)
+  C.check1 C.run ~name:"join . return = id" (join <.> return) Fun.id ;
+  C.check1 C.run2 ~name:"return . f = fmap f . return" (return <.> f)
+    (fmap f <.> return) ;
+  C.check1 C.run2 ~name:"join . fmap (fmap f) = fmap f . join"
+    (fun x -> pure (pure x) |> (join <.> fmap (fmap f)))
+    (fun x -> pure (pure x) |> (fmap f <.> join))
 
 let test_monad_ops (module M : MonadOps) =
   let module C = Check (M) in
   test_monad (module M) ;
   let open M in
-  C.check2 ~name:"m >> n = m >>= \\_ -> n"
+  C.check2 C.run ~name:"m >> n = m >>= \\_ -> n"
     (fun m n -> m >> n)
     (fun m n -> m >>= fun _ -> n)