Skip to content

Commit

Permalink
Use Repr.mu for representing recursive types
Browse files Browse the repository at this point in the history 
Thank you, art-w!
mirage/repr#108 (comment)
  • Loading branch information
@kentookura
kentookura committed Apr 6, 2024
1 parent 4fe2a99 commit dedc375
Showing 1 changed file with 43 additions and 37 deletions.
80 changes: 43 additions & 37 deletions lib/core/Rep.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,15 +40,20 @@ let range : Range.t ty =

(* A possible approach is to just pick a json representation and just send everything thru that? *)

let pp formatter a = () in
let pp = Range.dump in
let b =
{ source = `File "todo"; offset = 0; start_of_line = 0; line_num = 0 }
in
let e =
{ source = `File "todo"; offset = 0; start_of_line = 0; line_num = 0 }
in
let eof = Range.eof b in
let r = (Range.make (b, e)) in
(* We need to choose a string representation of ranges. *)
let of_string _ = Ok (Range.make (b, e)) in
let of_string str = Ok (Range.make (b,e))
(* try Scanf.sscanf str "@[<2>Range@ %a@]" (fun str -> Ok {v = str}) *)
(* with _ -> () *)
in
let encode encoder range = () in
let decode _ = Ok (Range.make (b, e)) in
let encode_bin : _ encode_bin = fun _ _ -> () in
Expand Down Expand Up @@ -120,7 +125,7 @@ module Tree : Irmin.Contents.S with type t = Sem.tree = struct
|+ field "address" string (fun t -> t.address)
|> sealr

let rec sem_node () : Sem.node ty =
let rec sem_node (t : Sem.t ty) (tree : Sem.tree ty) : Sem.node ty =
let open Sem in
variant "node"
(fun
Expand Down Expand Up @@ -155,39 +160,37 @@ module Tree : Irmin.Contents.S with type t = Sem.tree = struct
| Ref x -> ref x)
|~ case1 "Text" string (fun s -> Text s)
|~ case1 "Transclude"
(pair (tranclusion_opts ()) string)
(pair (tranclusion_opts t) string)
(fun (x, y) -> Transclude (x, y))
|~ case1 "Subtree"
(pair (tranclusion_opts ()) (tree ()))
(pair (tranclusion_opts t) tree)
(fun (x, y) -> Subtree (x, y))
|~ case1 "Query"
(pair (tranclusion_opts ()) (query (list (located_sem_node ()))))
(pair (tranclusion_opts t) (query tree t t))
(fun (x, y) -> Query (x, y))
|~ case1 "Xml_tag"
(triple string
(list @@ pair string (list (located_sem_node ())))
(list (located_sem_node ())))
(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 (list (located_sem_node ())))
(pair math_mode t)
(fun (x, y) -> Math (x, y))
|~ case1 "Link" (link ()) (fun s -> Link s)
|~ case1 "Embed_tex" (embed_tex ()) (fun s -> Embed_tex s)
|~ 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 (list (located_sem_node ())) (list (located_sem_node ())))
(pair t t)
(fun (x, y) -> If_tex (x, y))
|~ case1 "Prim" (pair prim (list (located_sem_node ()))) (fun (x, y) -> Prim (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 () : Sem.embed_tex ty =
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" (list (located_sem_node ())) (fun t -> t.preamble)
|+ field "source" (list (located_sem_node ())) (fun t -> t.source)
|+ field "preamble" t (fun t -> t.preamble)
|+ field "source" t (fun t -> t.source)
|> sealr

and modifier =
Expand All @@ -210,16 +213,17 @@ module Tree : Irmin.Contents.S with type t = Sem.tree = struct
pair (list string) int


and link () : Sem.link ty =
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 (list (located_sem_node ()))) (fun t -> t.label)
|+ field "label" (option t) (fun t -> t.label)
|+ field "modifier" (option modifier) (fun t -> t.modifier)
|> sealr

and query a : 'a Query.t ty =
and query (tree : Sem.tree ty) (t : Sem.t ty) a : 'a Query.t ty =
let open Query in
mu @@ fun query ->
variant "query" (fun author tag taxon meta or_ and_ not_ true_ -> function
| Author x -> author x
| Tag x -> tag x
Expand All @@ -233,20 +237,20 @@ module Tree : Irmin.Contents.S with type t = Sem.tree = struct
|~ 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 (list (located_sem_node ())))) (fun x -> Or x)
|~ case1 "And" (list (query (list (located_sem_node ())))) (fun x -> And x)
|~ case1 "Not" (query a) (fun x -> Not x)
|~ 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 () : Sem.node Range.located ty =
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 ()) (fun t -> t.value)
|+ field "value" (sem_node t tree) (fun t -> t.value)
|> sealr

and tranclusion_opts () =
and tranclusion_opts (t : Sem.t ty) =
let open Sem in
record "tranclusion_opts"
(fun
Expand All @@ -271,14 +275,14 @@ module Tree : Irmin.Contents.S with type t = Sem.tree = struct
|+ field "show_heading" bool (fun t -> t.show_heading)
|+ field "show_metadata" bool (fun t -> t.show_metadata)
|+ field "title_override"
(option (list (located_sem_node ())))
(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 () =
and frontmatter (t : Sem.t ty) =
let open Sem in
record "frontmatter"
(fun
Expand Down Expand Up @@ -309,14 +313,14 @@ module Tree : Irmin.Contents.S with type t = Sem.tree = struct
source_path;
number;
})
|+ field "title" (option (list (located_sem_node ()))) (fun t -> t.title)
|+ 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 (list (located_sem_node ()))))
(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)
Expand All @@ -325,14 +329,16 @@ module Tree : Irmin.Contents.S with type t = Sem.tree = struct
|+ field "number" (option string) (fun t -> t.number)
|> sealr

and tree () : Sem.tree ty =
let tree : Sem.tree ty =
let open Sem in
record "tree" (fun fm body : Sem.tree -> { fm; body })
|+ field "fm" (frontmatter ()) (fun t -> t.fm)
(* without annotation compiler thinks that t is obj_method due to `body` field *)
|+ field "body" (list (located_sem_node ())) (fun (t : Sem.tree) -> t.body)
|> sealr
mu (fun tree ->
let t = 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)

let t = tree ()
let t = tree
let merge = Irmin.Merge.(option (idempotent t))
end

0 comments on commit dedc375

Please sign in to comment.