struct: fixes, first (empty) synthesizer test

This commit is contained in:
ProgramSnail 2026-05-06 16:57:14 +00:00
parent 781fdbafd2
commit a130ffe819
3 changed files with 20 additions and 5 deletions

View file

@ -167,7 +167,7 @@ struct
[%%ocanren_inject
type nonrec ('sl, 'd, 'vl) t = ZeroV | SmthV | BotV | FunV of 'sl | RefV of 'd | TupleV of 'vl
[@@deriving gt ~options:{ show; gmap }]
type ground = ((Nat.ground List.ground * Stmt.ground) List.ground, Nat.ground, ground List.ground) t
type ground = (((* Nat.ground List.ground * *) Stmt.ground) List.ground, Nat.ground, ground List.ground) t
]
end
@ -814,8 +814,8 @@ struct
s == CallS (f, es) &
pathvalo mem vals f v &
pathtypeo types f tp &
types' == TypesEnv [] &
vals' == ValsEnv [] &
types' == TypesEnv [] & (* TODO: FIXME add globals *)
vals' == ValsEnv [] & (* TODO: FIXME add globals *)
v == FunV fstmts &
tp == FunT tps &
st' == StEnv (mem, types', vals') &
@ -867,9 +867,12 @@ struct
let prog_evalo prog st' =
let open Prg in
let open Stmt in
ocanren {
fresh decls, s, init_st in
prog == Prg (decls, s) &
decls == [] &
s == SkipS &
prog_inito prog init_st &
stmt_evalo init_st s st'
}

View file

@ -2,6 +2,8 @@ open Tests_f
open Synthesizer
open Relational
let%expect_test "prog eval test 1" = print_endline (prog_eval_t1 ()); [%expect {| [StEnv (MemEnv ([], O), TypesEnv ([]), ValsEnv ([]))] |}]
(* type tests *)
(* let%expect_test "Tag type test" = print_endline (Tag.Test.test ()); [%expect {| [Tag (Rd, NeverWr, Ref, In, NOut)] |}] *)
(* let%expect_test "Stmt type test (1)" = print_endline (Stmt.Test.test1 ()); [%expect {| [[S (S (O))]] |}] *)

View file

@ -4,7 +4,17 @@ open GT
open OCanren
open OCanren.Std
(* @type answer = St.ground GT.list with show *)
@type answer = StEnv.ground GT.list with show
let prog_eval_t1 _ = show(answer) (Stream.take (run q
(fun q -> let open Prg in
let open Stmt in
ocanren {
fresh prog in
prog == Prg ([], SkipS) &
prog_evalo prog q})
(fun q -> q#reify (StEnv.prj_exn))))
(* @type answerArgs = (Arg.ground List.ground) GT.list with show *)
(* @type answerValue = Value.ground GT.list with show *)
(* @type answerNat = Nat.ground GT.list with show *)