Example request: representations of abstract types that work with irmin #108
Comments
|
Very cool to see Forester experimenting with Irmin! Here's a complete example of open Lwt.Syntax
type foo = { v : string } [@@deriving repr]
module Abstract : Irmin.Contents.S with type t = foo = struct
type t = foo
let t : foo Repr.ty =
let pp h foo =
Format.fprintf h "{ v = %S }" foo.v
in
let of_string str =
(* Must be able to decode the output of [pp] *)
try Scanf.sscanf str "{ v = %S }" (fun str -> Ok { v = str })
with _ -> Error (`Msg "of_string")
in
let encode_json encoder foo =
let (`Ok | _) = Jsonm.encode encoder (`Lexeme `Os) in
let (`Ok | _) = Jsonm.encode encoder (`Lexeme (`Name "v")) in
let (`Ok | _) = Jsonm.encode encoder (`Lexeme (`String foo.v)) in
let (`Ok | _) = Jsonm.encode encoder (`Lexeme `Oe) in
()
in
let decode_json decoder =
(* Must be able to decode the output of [encode_json] *)
let (let*) = Result.bind in
let* () = Repr.Json.decode decoder |> function `Lexeme `Os -> Ok () | _ -> Error (`Msg "decode_json") in
let* () = Repr.Json.decode decoder |> function `Lexeme (`Name "v") -> Ok () | _ -> Error (`Msg "decode_json") in
let* v = Repr.Json.decode decoder |> function `Lexeme (`String v) -> Ok v | _ -> Error (`Msg "decode_json") in
let* () = Repr.Json.decode decoder |> function `Lexeme `Oe -> Ok () | _ -> Error (`Msg "decode_json") in
Ok { v = v }
in
let encode_bin foo write =
Repr.Binary.Varint.encode (String.length foo.v) write ;
write foo.v
in
let decode_bin buffer at =
(* Must be able to decode the output of [encode_bin] *)
let len = Repr.Binary.Varint.decode buffer at in
let v = String.sub buffer !at len in
at := !at + len ;
{ v }
in
let size =
Repr.Size.custom_dynamic
~of_value:(fun foo ->
(* Optional, precompute the size that will be used by [encode_bin] *)
let len = String.length foo.v in
let varint_len_size = ref 0 in
Repr.Binary.Varint.encode len
(fun s -> varint_len_size := !varint_len_size + String.length s) ;
!varint_len_size + len)
~of_encoding:(fun str offset ->
(* You can skip this function, it's unused nowadays *)
let at = ref offset in
let len = Repr.Binary.Varint.decode str at in
let varint_len_size = !at - offset in
varint_len_size + len)
()
in
let pre_hash =
(* Same as [encode_bin], unless the binary serialization has changed
but we want to preserve the previous cryptographic hash for
backward compatibility. *)
encode_bin
in
let equal a b = String.equal a.v b.v in
let compare a b = String.compare a.v b.v in
let short_hash ?seed foo =
match seed with
| None -> Hashtbl.hash foo.v
| Some seed -> Hashtbl.seeded_hash seed foo.v
in
Repr.abstract
~pp ~of_string
~json:(encode_json, decode_json)
~bin:(encode_bin, decode_bin, size)
~pre_hash
~equal ~compare ~short_hash
()
let merge = Irmin.Merge.(option (idempotent t))
end
module Store = Irmin_git_unix.FS.KV (Abstract)
module Info = Irmin_unix.Info (Store.Info)
let info message = Info.v ~author:"Example" "%s" message
let main_branch config =
let* repo = Store.Repo.v config in
Store.main repo
let test schema foo =
let pretty_string = Format.asprintf "%a" (Repr.pp schema) foo in
assert (pretty_string = Repr.to_string schema foo) ;
Format.printf "pp: %s@." pretty_string;
let r = Repr.of_string schema pretty_string in
assert (r = Ok foo) ;
let buf = Buffer.create 16 in
let encoder = Jsonm.encoder ~minify:true (`Buffer buf) in
Repr.encode_json schema encoder foo ;
let (`Ok | _) = Jsonm.encode encoder `End in
let json_encoded = Buffer.contents buf in
Format.printf "json: %S@." json_encoded ;
assert (json_encoded = Printf.sprintf {|{"v":%S}|} foo.v) ;
let decoder = Jsonm.decoder (`String json_encoded) in
let r = Repr.decode_json schema decoder in
assert (r = Ok foo) ;
let binstr = Repr.(unstage (to_bin_string schema)) foo in
Format.printf "binstring = %S@." binstr ;
let r = Repr.(unstage (of_bin_string schema)) binstr in
assert (r = Ok foo) ;
let expected_size = match Repr.(unstage (size_of schema)) foo with
| None -> failwith "unable to precompute binstring length"
| Some s -> s
in
Format.printf "expected_size = %i@." expected_size ;
assert (expected_size = String.length binstr) ;
let short_hash = Repr.(unstage (short_hash schema)) foo in
Format.printf "short_hash = %#i@." short_hash ;
()
let main =
let config = Irmin_git.config ~bare:true "/tmp/irmin" in
let* t = main_branch config in
let* () = Store.set_exn t ["a"] { v = "foo" } ~info:(info "first commit") in
let+ s = Store.get t ["a"] in
assert (s = { v = "foo" } ) ;
Format.printf "# Abstract test:@." ;
test Abstract.t s ;
Format.printf "@." ;
Format.printf "# PPX test:@." ;
test foo_t s
let () = Lwt_main.run mainFor the Regarding the stack overflow, it's likely coming from https://github.com/kentookura/ocaml-forester/blob/irmin/lib/core/Rep.ml#L336 as recursive types must be explicitly created with I haven't tested it thoroughly but for example: (... other definitions from Rep.Tree ...) (* can probably remove the [rec]? *)
let rec sem_node (t : Sem.t ty) (tree : Sem.tree ty) : Sem.node ty =
let open Sem in
variant "node"
(fun
text
transclude
subtree
query
xml_tag
unresolved
math
link
embed_tex
img
if_tex
prim
object_
ref
-> function
| Text s -> text s
| Transclude (x, y) -> transclude (x, y)
| Subtree (x, y) -> subtree (x, y)
| Query (x, y) -> query (x, y)
| Xml_tag (x, y, z) -> xml_tag (x, y, z)
| Unresolved x -> unresolved x
| Math (x, y) -> math (x, y)
| Link x -> link x
| Embed_tex x -> embed_tex x
| Img x -> img x
| If_tex (x, y) -> if_tex (x, y)
| Prim (x, y) -> prim (x, y)
| Object x -> object_ x
| Ref x -> ref x)
|~ case1 "Text" string (fun s -> Text s)
|~ case1 "Transclude"
(pair (tranclusion_opts t) string)
(fun (x, y) -> Transclude (x, y))
|~ case1 "Subtree"
(pair (tranclusion_opts t) tree)
(fun (x, y) -> Subtree (x, y))
|~ case1 "Query"
(pair (tranclusion_opts t) (query tree t t))
(fun (x, y) -> Query (x, y))
|~ case1 "Xml_tag"
(triple string (list @@ pair string t) t)
(fun (x, y, z) -> Xml_tag (x, y, z))
|~ case1 "Unresolved" string (fun s -> Unresolved s)
|~ case1 "Math"
(pair math_mode t)
(fun (x, y) -> Math (x, y))
|~ case1 "Link" (link t ) (fun s -> Link s)
|~ case1 "Embed_tex" (embed_tex t) (fun s -> Embed_tex s)
|~ case1 "Img" img (fun s -> Img s)
|~ case1 "If_tex"
(pair t t)
(fun (x, y) -> If_tex (x, y))
|~ case1 "Prim" (pair prim t) (fun (x, y) -> Prim (x, y))
|~ case1 "Object_" symbol (fun s -> Object s)
|~ case1 "Ref" ref_cfg (fun s -> Ref s)
|> sealv
and embed_tex (t : Sem.t ty) : Sem.embed_tex ty =
let open Sem in
record "embed_tex" (fun preamble source -> { preamble; source })
|+ field "preamble" t (fun t -> t.preamble)
|+ field "source" t (fun t -> t.source)
|> sealr
and modifier =
let open Sem in
enum "modifier" [ ("sentence_case", `Sentence_case)]
and img : Sem.img ty =
let open Sem in
record "img" (fun path -> { path })
|+ field "path" string (fun t -> t.path)
|> sealr
and ref_cfg : Sem.ref_cfg ty =
let open Sem in
record "ref_cfg" (fun address -> { address })
|+ field "address" string (fun t -> t.address)
|> sealr
and symbol : Symbol.t ty = let open Symbol in
pair (list string) int
and link (t : Sem.t ty) : Sem.link ty =
let open Sem in
record "link" (fun dest label modifier -> { dest; label; modifier })
|+ field "dest" string (fun t -> t.dest)
|+ field "label" (option t) (fun t -> t.label)
|+ field "modifier" (option modifier) (fun t -> t.modifier)
|> sealr
and query (tree : Sem.tree ty) (t : Sem.t ty) a : 'a Query.t ty =
let open Query in
Repr.mu @@ fun query ->
variant "query" (fun author tag taxon meta or_ and_ not_ true_ -> function
| Author x -> author x
| Tag x -> tag x
| Taxon x -> taxon x
| Meta (x, y) -> meta (x, y)
| Or x -> or_ x
| And x -> and_ x
| Not x -> not_ x
| True -> true_)
|~ case1 "Author" a (fun x -> Author x)
|~ case1 "Tag" a (fun x -> Tag x)
|~ case1 "Taxon" a (fun x -> Taxon x)
|~ case1 "Meta" (pair string a) (fun (x, y) -> Meta (x, y))
|~ case1 "Or" (list query) (fun x -> Or x)
|~ case1 "And" (list query) (fun x -> And x)
|~ case1 "Not" query (fun x -> Not x)
|~ case0 "True" True |> sealv
and located_sem_node (t : Sem.t ty) (tree : Sem.tree ty) : Sem.node Range.located ty =
let open Asai in
let open Range in
record "located_sem_node" (fun loc value -> { loc; value })
|+ field "loc" (option range) (fun t -> None)
|+ field "value" (sem_node t tree) (fun t -> t.value)
|> sealr
and tranclusion_opts (t : Sem.t ty) =
let open Sem in
record "tranclusion_opts"
(fun
toc
show_heading
show_metadata
title_override
taxon_override
expanded
numbered
->
{
toc;
show_heading;
show_metadata;
title_override;
taxon_override;
expanded;
numbered;
})
|+ field "toc" bool (fun t -> t.toc)
|+ field "show_heading" bool (fun t -> t.show_heading)
|+ field "show_metadata" bool (fun t -> t.show_metadata)
|+ field "title_override"
(option t)
(fun t -> t.title_override)
|+ field "taxon_override" (option string) (fun t -> t.taxon_override)
|+ field "expanded" bool (fun t -> t.expanded)
|+ field "numbered" bool (fun t -> t.numbered)
|> sealr
and frontmatter (t : Sem.t ty) =
let open Sem in
record "frontmatter"
(fun
title
taxon
authors
contributors
dates
addr
metas
tags
physical_parent
designated_parent
source_path
number
->
{
title;
taxon;
authors;
contributors;
dates;
addr;
metas;
tags;
physical_parent;
designated_parent;
source_path;
number;
})
|+ field "title" (option t) (fun t -> t.title)
|+ field "taxon" (option string) (fun t -> t.taxon)
|+ field "authors" (list string) (fun t -> t.authors)
|+ field "contributors" (list string) (fun t -> t.contributors)
|+ field "dates" (list date) (fun t -> t.dates)
|+ field "addr" (option string) (fun t -> t.addr)
|+ field "metas"
(list (pair string t))
(fun t -> t.metas)
|+ field "tags" (list string) (fun t -> t.tags)
|+ field "physical_parent" (option string) (fun t -> t.physical_parent)
|+ field "designated_parent" (option string) (fun t -> t.designated_parent)
|+ field "source_path" (option string) (fun t -> t.source_path)
|+ field "number" (option string) (fun t -> t.number)
|> sealr let t : Sem.tree ty =
let open Sem in
Repr.mu (fun tree ->
let t = Repr.mu (fun t -> list (located_sem_node t tree)) in
record "tree" (fun fm body : Sem.tree -> { fm; body })
|+ field "fm" (frontmatter t) (fun t -> t.fm)
(* without annotation compiler thinks that t is obj_method due to `body` field *)
|+ field "body" t (fun (t : Sem.tree) -> t.body)
|> sealr) |
kentookura
added a commit
to kentookura/ocaml-forester
that referenced
this issue
Apr 6, 2024
Thank you, art-w! mirage/repr#108 (comment)
|
Thanks a lot! I've applied your suggestions and it works well. |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
The following code compiles but results in an error (not surprising since we are asserting false):
I encountered this when trying to track down the following issue:
I have some representations of types, but when adapting the above code it results in a stack overflow:
https://github.com/kentookura/ocaml-forester/blob/irmin/bin/forest-manager/main.ml
Could the reason for this be the unimplemented size functions for the representation of Range?
https://github.com/kentookura/ocaml-forester/blob/4fe2a99ad9869e155d8b8c124846e0ecd2380f73/lib/core/Rep.ml#L83
I would like to request a fully worked example of representing abstract types that works with irmin. It would help me track down where the error lies in my code. Thanks!
The text was updated successfully, but these errors were encountered: