Skip to content
GitLab
Commit 0dd11ff9 authored by Vlad Dumitru's avatar Vlad Dumitru
Browse files

broken code so far, but afraid to lose it

parent d321af8c
Pipeline #6044 canceled with stages
in 41 seconds
Hide whitespace changes
Inline Side-by-side
bin/action.ml
View file @ 0dd11ff9
......@@ -21,7 +21,7 @@ let store_textgrid ~db ?author ?comment ?date ~tg_path ~key () =
match Annotation.Textgrid.Read.of_string contents with
| Ok tg ->
Ok (Base.List.map ~f:(fun tier ->
let doc = Speechcake.Document.v ~key tier in
let doc = Speechcake.Document.v ~key (Annotation.Tier.data tier) in
let uuid = Uuidm.v `V4 in
Speechcake.put db ?author ?comment ?date (Uuidm.to_string uuid) doc) tg)
| Error e ->
......@@ -121,16 +121,16 @@ let put ~db ~tiers ~tier_name ~key =
match tier with
| Some tier ->
let uuid = Uuidm.v `V4 in
let doc = Speechcake.Document.v ~key tier in
let doc = Speechcake.Document.v ~key (Annotation.Tier.data tier) in
Ok (uuid, Speechcake.put db ~parents:[] (Uuidm.to_string uuid) doc)
| None ->
Error (`Unknown_tier tier_name)
let most_recent_version bkt versions =
Base.List.map versions ~f:(fun v -> Base.Result.map (Speechcake.Database.VS.get bkt v) ~f:(fun d -> v, d))
Base.List.map versions ~f:(fun v -> Base.Result.map (Speechcake.Database.VS.version bkt v) ~f:(fun d -> v, d))
|> Base.List.filter_map ~f:Base.Result.ok
|> Base.List.dedup_and_sort ~compare:(fun (_, (_, x)) (_, (_, y)) ->
let open Speechcake.Database.VS.Metadata in
let open Speechcake.Store.Info in
String.compare (date x) (date y))
|> Base.List.rev
|> Base.List.hd_exn
......@@ -154,8 +154,8 @@ let update ~db ~tiers ~tier_name ~uuid ~branch =
Speechcake.get_latest db key
>>= fun (_, _, latest) ->
let doc = Speechcake.Document.v
~key:latest.Speechcake.Document.key ~tags:latest.tags tier in
Speechcake.put db key ~parents:[] ~tag:branch doc
~key:latest.Speechcake.Document.key ~labels:latest.labels tier in
Speechcake.put db key ~parents:[] ~branch doc
| Known { uuid; parents; name } ->
let parents' = Base.List.filter_map parents ~f:Speechcake.Database.VS.Hash.of_string in
Speechcake.bucket db (Uuidm.to_string uuid)
......@@ -163,8 +163,8 @@ let update ~db ~tiers ~tier_name ~uuid ~branch =
most_recent_version bucket parents'
|> fun (_most_recent_version, most_recent_doc, _most_recent_meta) ->
let doc = Speechcake.Document.v
~key:most_recent_doc.Speechcake.Document.key ~tags:most_recent_doc.tags tier in
Speechcake.put ~parents:parents' ~tag:branch db key doc
~key:most_recent_doc.Speechcake.Document.key ~labels:most_recent_doc.labels tier in
Speechcake.put ~parents:parents' ~branch db key doc
|> (function
| Ok hash -> Ok hash
| Error (`Conflict_set (tx, ty)) ->
......@@ -173,6 +173,7 @@ let update ~db ~tiers ~tier_name ~uuid ~branch =
let ty = Speechcake.Document.stamp (info (Fmt.str "%s(2)" name)) ty in
let tg = Annotation.Textgrid.Write.to_string [ None, tx; None, ty ] in
Error (`Conflict_textgrid tg)
| Error `Illegal_move -> Error `Illegal_move
| Error (`Decoding_error e) -> Error (`Decoding_error e)
| Error (`Merge_error e) -> Error (`Merge_error e)
| Error (`Persistent_store_error e) -> Error (`Persistent_store_error e)
......@@ -210,16 +211,16 @@ let rec has_prefix ~prefix key =
| [], [] ->
true
let has_one_of_tags ?tags doc_tags =
match tags with
| Some tags -> not (Base.Set.are_disjoint tags doc_tags)
| None -> true
let has_one_of_labels ?labels doc_tags =
match labels with
| Some labels -> not (Base.Set.are_disjoint labels doc_tags)
| None -> true
let list_tiers ?prefix ?tags db =
let list_tiers ?prefix ?labels db =
Log.info (fun m ->
m "list_tiers prefix=%a tags=%a"
m "list_tiers prefix=%a labels=%a"
Fmt.(option ~none:(any "(none)") (list ~sep:(any "/") string)) prefix
Fmt.(option ~none:(any "(none)") (list ~sep:(any ",@ ") string)) (Base.Option.map ~f:Base.Set.to_list tags)) ;
Fmt.(option ~none:(any "(none)") (list ~sep:(any ",@ ") string)) (Base.Option.map ~f:Base.Set.to_list labels)) ;
let key_index =
Speechcake.Database.list db.Speechcake.db
|> Base.List.map ~f:(fun uuid ->
......@@ -227,7 +228,8 @@ let list_tiers ?prefix ?tags db =
|> Base.List.bind ~f:(function
| Ok doc ->
[ doc ]
| Error (`Decoding_error e) ->
| Error (`Decoding_error e)
| Error (`Persistent_store_error (`Decoding_error e))->
Log.err (fun m ->
m "decoding error: %s"
(Decoders_yojson.Basic.Decode.string_of_error e)) ;
......@@ -249,10 +251,10 @@ let list_tiers ?prefix ?tags db =
| Some prefix ->
key_index
|> Base.List.filter ~f:(fun (_, (_, _, doc)) -> has_prefix ~prefix doc.Speechcake.Document.key)
|> Base.List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_tags ?tags doc.Speechcake.Document.tags)
|> Base.List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_labels ?labels doc.Speechcake.Document.labels)
| None ->
key_index
|> Base.List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_tags ?tags doc.Speechcake.Document.tags)
|> Base.List.filter ~f:(fun (_, (_, _, doc)) -> has_one_of_labels ?labels doc.Speechcake.Document.labels)
(*
......
bin/codec.ml
View file @ 0dd11ff9
......@@ -21,7 +21,7 @@ let encode_tier_listing : (string * string list * (string, String.comparator_wit
|> fun tier_listing -> `List tier_listing
let encode_version_info metadata =
let open Speechcake.Database.VS.Metadata in
let open Speechcake.Database.VS.Info in
`Assoc
[ "author", `String (author metadata)
; "comment", `String (comment metadata)
......@@ -29,25 +29,26 @@ let encode_version_info metadata =
; "parents", `List (Base.List.map (parents metadata) ~f:(fun p -> `String (string_of_hash p)))
]
let encode_version (hash, (info, branch_head)) =
let encode_version (hash, info) =
let branch_head = None in
match branch_head with
| Some branch_head ->
`Assoc
[ "id", `String (Speechcake.Database.VS.Metadata.string_of_hash hash)
[ "id", `String (Speechcake.Database.VS.Info.string_of_hash hash)
; "info", encode_version_info info
; "head", `String branch_head
]
| None ->
`Assoc
[ "id", `String (Speechcake.Database.VS.Metadata.string_of_hash hash)
[ "id", `String (Speechcake.Database.VS.Info.string_of_hash hash)
; "info", encode_version_info info
]
let encode_version_listing : (Speechcake.Database.VS.Metadata.hash * (Speechcake.Database.VS.Metadata.t * string option)) list encoder =
let encode_version_listing : (Speechcake.Database.VS.Info.hash * Speechcake.Database.VS.Info.t) list encoder =
fun versions ->
versions
|> Base.List.dedup_and_sort ~compare:(fun (_, (x, _)) (_, (y, _)) ->
let dx, dy = Speechcake.Database.VS.Metadata.(date x, date y) in
|> Base.List.dedup_and_sort ~compare:(fun (_, x) (_, y) ->
let dx, dy = Speechcake.Database.VS.Info.(date x, date y) in
String.compare dx dy)
|> Base.List.rev
|> Base.List.map ~f:encode_version
......@@ -67,7 +68,7 @@ let encode_read_error =
type tier_info =
string * ([ `Fresh of
[ `Possibly_one_of of (string list * Uuidm.t * int * string list) list
| `Exactly of (Uuidm.t * Speechcake.Database.VS.hash * string option) * (Speechcake.Database.VS.Metadata.t * Speechcake.Document.t)
| `Exactly of (Uuidm.t * Speechcake.Database.VS.hash) * (Speechcake.Database.VS.Info.t * Speechcake.Document.t)
]
| `Known of Uuidm.t * string list * Speechcake.Database.VS.hash * string list
| `Conflict_resolution of Uuidm.t * Speechcake.Database.VS.hash list
......@@ -98,7 +99,7 @@ let encode_tier_info : tier_info -> string * Yojson.Basic.t =
[ "type", `String "fresh"
; "matches", `List (Base.List.map matches ~f:encode_tier_match)
]
| name, Ok (`Fresh (`Exactly ((uuid, version, branch), (meta, doc)))) ->
| name, Ok (`Fresh (`Exactly ((uuid, version), (meta, doc)))) ->
name, `Assoc
([ "type", `String "exactly"
; "uuid", `String (Uuidm.to_string uuid)
......@@ -107,7 +108,7 @@ let encode_tier_info : tier_info -> string * Yojson.Basic.t =
[ "id", `String (Speechcake.Database.VS.Hash.to_string version)
; "meta", encode_version_info meta
]
] @ (Option.to_list (Option.map branch ~f:(fun b -> "branch", `String b))))
])
| name, Ok (`Known (uuid, key, version, forbidden_branches)) ->
name, `Assoc
[ "type", `String "known"
......
bin/konditorei.ml
View file @ 0dd11ff9
......@@ -126,14 +126,14 @@ let cors inner_handler request =
let get_tiers db ?prefix request =
let tags =
Dream.query "tags" request
let labels =
Dream.query "labels" request
|> Option.map ~f:(String.split ~on:',')
|> Option.map ~f:(Set.of_list (module String)) in
let tiers = Action.list_tiers ?prefix ?tags db in
let tiers = Action.list_tiers ?prefix ?labels db in
let body =
tiers
|> List.map ~f:(fun (uuid, (_, _, doc)) -> uuid, doc.Speechcake.Document.key, doc.Speechcake.Document.tags)
|> List.map ~f:(fun (uuid, (_, _, doc)) -> uuid, doc.Speechcake.Document.key, doc.Speechcake.Document.labels)
|> C.encode_tier_listing
|> Yojson.Safe.to_string in
Dream.json body
......@@ -200,7 +200,7 @@ let get_tier db request =
`Assoc
[ "key", `List (List.map doc.Speechcake.Document.key ~f:(fun part -> `String part))
; "uuid", `String uuid
; "tags", `List (List.map (Set.to_list doc.tags) ~f:(fun tag -> `String tag))
; "labels", `List (List.map (Set.to_list doc.labels) ~f:(fun label -> `String label))
; "versions", C.encode_version_listing branches
(*; "branches", `List (Base.List.map branches ~f:(fun (name, ptr) ->
`List [ `String name; `String (Speechcake.Database.VS.Metadata.string_of_hash ptr)]))*)
......@@ -219,6 +219,26 @@ let get_tier db request =
| Error (`Decoding_error e) ->
Dream.respond ~status:`Bad_Request (Decoders_yojson.Basic.Decode.string_of_error e)
(*
let put_tier db tier =
match Speechcake.Document.unstamp tier with
| Ok (Fresh name, tier) ->
begin match Speechcake.identify db tier with
| `Exactly ((uuid, v, branch), _) -> Ok (`Synchronized (uuid, branch, v))
| `Possibly_one_of matches -> Ok (`Choose_destination matches)
end
| Ok (Known { name; uuid; parents=[ parent ] }, tier) ->
let open Base.Result.Monad_infix in
Speechcake.bucket db (Uuidm.to_string uuid)
>>= fun store ->
Speechcake.Database.VS.Hash.of_string parent
|> Result.of_option ~error:(`Unknown_version parent)
>>= fun parent ->
begin match Speechcake.Database.VS.(branch_of_hash store parent) with
| branch :: [] ->
Speechcake.put ~parents:[ parent ] ~branch db (Uuidm.to_string uuid) tier
*)
let put_textgrid db request =
let open Lwt.Syntax in
......@@ -271,6 +291,8 @@ let string_of_error = function
let json_of_error =
let open Decoders_yojson.Basic.Encode in
function
| `Branch_not_found b -> obj [ "name", string "branch not found"; "which", string b ]
| `Illegal_move -> obj [ "name", string "illegal move" ]
| `Parsing_error e -> obj [ "name", string "parsing error"; "reason", string e ]
| `Empty_bucket u -> obj [ "name", string "empty bucket"; "which", string (Uuidm.to_string u) ]
| `Empty_tier -> obj [ "name", string "empty tier" ]
......@@ -293,8 +315,8 @@ let json_of_error =
obj [ "name", string "merging points and intervals" ]
| `Merge_error (`Conflict_set (tx, ty)) ->
obj [ "name", string "conflict set"
; "tx", Annotation.Tier.to_json tx
; "ty", Annotation.Tier.to_json ty
; "tx", Annotation.Tier.encoder tx
; "ty", Annotation.Tier.encoder ty
]
| `Conflict_textgrid tg ->
obj [ "name", string "conflict textgrid"
......@@ -319,53 +341,47 @@ let store_tier db ~tiers request =
end
let set_key db request =
let perform ~uuid ?(tag="latest") key =
let perform ~uuid ?(branch="latest") key =
let open Result.Monad_infix in
Uuidm.of_string uuid |> Result.of_option ~error:(`Invalid_UUID uuid)
>>= fun uuid ->
Speechcake.get_tagged db (Uuidm.to_string uuid) ~tag
>>= fun (parent_hash, _parent_meta, parent_doc) ->
Speechcake.get_head db (Uuidm.to_string uuid) ~branch
>>= fun (parent_hash, parent_doc, _parent_meta) ->
let doc' = { parent_doc with key } in
let comment =
Fmt.(str "move from `%a`" (list ~sep:(any "/") string) parent_doc.key) in
Speechcake.put ~parents:[parent_hash] ~comment ~tag db (Uuidm.to_string uuid) doc'
>>| fun version ->
Speechcake.update_key_index db.key_index key uuid ;
version
Speechcake.put ~parents:[parent_hash] ~comment ~branch db (Uuidm.to_string uuid) doc'
in
let open Lwt.Syntax in
let uuid = Dream.param "uuid" request in
let tag = Dream.param "tag" request in
let* key = Dream.body request in
match perform ~uuid ~tag (String.split ~on:'/' key) with
let uuid = Dream.param "uuid" request in
let branch = Dream.param "branch" request in
let* key = Dream.body request in
match perform ~uuid ~branch (String.split ~on:'/' key) with
| Ok ver ->
Dream.respond ~status:`Created (Speechcake.Database.VS.Hash.to_string ver)
| Error e ->
Dream.json ~status:`Internal_Server_Error (json_of_error e |> Yojson.Basic.to_string)
let set_tags db request =
let perform ~uuid ?(tag="latest") tags =
let set_labels db request =
let perform ~uuid ?(branch="latest") labels =
let open Result.Monad_infix in
Uuidm.of_string uuid |> Result.of_option ~error:(`Invalid_UUID uuid)
>>= fun uuid ->
Speechcake.get_tagged db (Uuidm.to_string uuid) ~tag
>>= fun (parent_hash, _parent_meta, parent_doc) ->
let doc' = { parent_doc with tags } in
let comment = "change tags" in
Speechcake.put ~parents:[parent_hash] ~comment ~tag db (Uuidm.to_string uuid) doc'
>>| fun version ->
Speechcake.update_tag_index db.tag_index uuid tags ;
version
Speechcake.get_head db (Uuidm.to_string uuid) ~branch
>>= fun (parent_hash, parent_doc, _parent_meta) ->
let doc' = { parent_doc with labels } in
let comment = "change labels" in
Speechcake.put ~parents:[parent_hash] ~comment ~branch db (Uuidm.to_string uuid) doc'
in
let open Lwt.Syntax in
let uuid = Dream.param "uuid" request in
let tag = Dream.param "tag" request in
let* tags = Dream.body request in
let tags =
Decoders_yojson.Basic.Decode.(decode_string (list string) tags)
let uuid = Dream.param "uuid" request in
let branch = Dream.param "branch" request in
let* labels = Dream.body request in
let labels =
Decoders_yojson.Basic.Decode.(decode_string (list string) labels)
|> Result.map ~f:(Set.of_list (module String))
|> Result.map_error ~f:(fun e -> `Decoding_error e) in
let result = Result.bind tags ~f:(perform ~uuid ~tag) in
let result = Result.bind labels ~f:(perform ~uuid ~branch) in
match result with
| Ok ver ->
Dream.respond ~status:`Created (Speechcake.Database.VS.Hash.to_string ver)
......@@ -571,14 +587,9 @@ let read_user_list () =
| Error error -> failwith (Decoders_yojson.Basic.Decode.string_of_error error)
let run_server repo_path interface port =
let server db user_list =
let open Dream in
initialize_log ~level:`Debug () ;
let db = init repo_path in
let user_list = read_user_list () in
run ~interface ~port
@@ logger
logger
@@ cors
@@ authenticated user_list
@@ router
......@@ -606,8 +617,8 @@ let run_server repo_path interface port =
; post "/util/diff-tiers" (diff_tiers db)
(* tier metadata setters *)
; put "/tier/:uuid/head/:tag/key" (set_key db)
; put "/tier/:uuid/head/:tag/tags" (set_tags db)
; put "/tier/:uuid/head/:tag/key" (set_key db)
; put "/tier/:uuid/head/:tag/labels" (set_labels db)
(* tier -> textgrid export *)
; get "/tier/:uuid/head/:tag/export" (export_tier db)
......@@ -621,6 +632,14 @@ let run_server repo_path interface port =
]
@@ not_found
let run_server repo_path interface port =
let open Dream in
initialize_log ~level:`Debug () ;
let db = init repo_path in
let user_list = read_user_list ()
in
run ~interface ~port (server db user_list)
let cmd =
let open Cmdliner in
let open Term in
......
bin/tort.ml
View file @ 0dd11ff9
open Core
open Cmdliner
(*
environment params: DB_PATH
commands:
- extract <textgrid-path> <tier-name> -> <tier-as-json>
- persist <bucket> <json> -> <value>
- commit --author <author> --comment <comment> --tag <tag> <value> -> <version>
#!/bin/bash
JSON=$(tort extract 001M002M.TextGrid 001M)
VALUE=$(echo $JSON | tort persist 001M)
VERSION=$(tort commit "version one" --tag "latest" $VALUE)
*)
let src = Logs.Src.create "tort" ~doc:"tort events"
module Log = (val Logs.src_log src : Logs.LOG)
......@@ -84,29 +69,29 @@ let extract () path name =
in
match result with
| Ok tier ->
Fmt.pr "%s@." (Yojson.Basic.to_string (Annotation.Tier.to_json tier))
Fmt.pr "%s@." (Yojson.Basic.to_string (Annotation.Tier.encoder tier))
| Error (`Parsing_error e) ->
Fmt.epr "parsing error: %s@." e
| Error (`Tier_not_found t) ->
Fmt.epr "tier not found: %s@." t
let wrap () key tags =
let wrap () key labels =
let key = String.split key ~on:'/' in
let tags =
String.split tags ~on:','
let labels =
String.split labels ~on:','
|> Set.of_list (module String) in
let contents =
In_channel.input_all In_channel.stdin
|> Yojson.Basic.from_string
|> Decoders_yojson.Basic.Decode.decode_value Annotation.Tier.of_json in
|> Decoders_yojson.Basic.Decode.decode_value Annotation.Tier.decoder in
match contents with
| Ok tier ->
let doc = Speechcake.Document.v ~key ~tags tier in
let doc = Speechcake.Document.v ~key ~labels tier in
Fmt.pr "%s@." (Yojson.Basic.to_string (Speechcake.Document.encoder doc))
| Error e ->
Fmt.epr "decoding error: %s@." (Decoders_yojson.Basic.Decode.string_of_error e)
let commit () root key author comment =
let commit () root key branch author comment =
let result =
let open Result.Monad_infix in
In_channel.input_all In_channel.stdin
......@@ -115,10 +100,10 @@ let commit () root key author comment =
>>= fun document -> bucket_of_file (root ^ "/" ^ key)
>>= fun store ->
let date = ISO8601.Permissive.string_of_datetime (Unix.gettimeofday ()) in
let meta = Speechcake.Database.VS.Metadata.v ~author ~date ~comment () in
let store', hash = Speechcake.Database.VS.put store document ~meta in
Speechcake.Database.VS.put ~author ~date ~comment ~parents:[] ~branch store document
>>= fun hash ->
Out_channel.write_all (root ^ "/" ^ key)
~data:(Yojson.Basic.to_string (Speechcake.Database.VS.Encode.dump store')) ;
~data:(Yojson.Basic.to_string (Speechcake.Database.VS.Encode.dump store)) ;
Ok hash
in
match result with
......@@ -126,6 +111,12 @@ let commit () root key author comment =
Fmt.pr "%a@." Speechcake.Database.VS.Hash.pp hash
| Error (`Decoding_error e) ->
Fmt.epr "decoding error: %s@." (Decoders_yojson.Basic.Decode.string_of_error e)
| Error (`Illegal_move) ->
Fmt.epr "illegal move@."
| Error (`Merge_error _) ->
Fmt.epr "merge error@."
| Error (`Persistent_store_error _) ->
Fmt.epr "persistent store error@."
let tag () root key name hash =
let result =
......@@ -190,11 +181,11 @@ let wrap_t =
let key =
let doc = "Key of the destination bucket" in
Arg.(value & pos 0 string "" & info [] ~docv:"KEY" ~doc) in
let tags =
let labels =
let doc = "Short identifiers (comma-separated)" in
Arg.(value & opt string "" & info [ "t"; "tags" ] ~docv:"TAGS" ~doc) in
Arg.(value & opt string "" & info [ "l"; "labels" ] ~docv:"LABELS" ~doc) in
let doc = "Wrap a tier into a document (adding metadata)" in
( const wrap $ setup $ key $ tags
( const wrap $ setup $ key $ labels
, info ~doc "wrap"
)
......@@ -207,6 +198,9 @@ let commit_t =
let key =
let doc = "Key of the destination bucket" in
Arg.(value & pos 0 string "" & info [] ~docv:"KEY" ~doc) in
let branch =
let doc = "Branch to commit to" in
Arg.(value & opt string "latest" & info [ "b"; "branch" ] ~docv:"BRANCH" ~doc) in
let author =
let doc = "Name of the author" in
Arg.(value & opt string "Anonymous" & info [ "a"; "author" ] ~docv:"AUTHOR" ~doc) in
......@@ -214,7 +208,7 @@ let commit_t =
let doc = "Description of this version" in
Arg.(value & opt string "" & info [ "c"; "comment" ] ~docv:"COMMENT" ~doc) in
let doc = "Commit a value to the store" in
( const commit $ setup $ root $ key $ author $ comment
( const commit $ setup $ root $ key $ branch $ author $ comment
, info ~doc "commit"
)
......
lib/annotation/tier.ml
View file @ 0dd11ff9
......@@ -13,6 +13,9 @@ module Data = struct
| Intervals is -> Fmt.(list ~sep:comma Interval.pp) ppf is
| Points ps -> Fmt.(list ~sep:comma Point.pp) ppf ps
let to_string =
Fmt.to_to_string pp
let of_points ps = Points ps
let of_intervals is = Intervals is
......@@ -63,7 +66,7 @@ module Data = struct
let l, r = lbound data, rbound data in
Option.value_exn l, Option.value_exn r
let diff (type t) (module E : Element.S with type t = t) xs ys =
let diff_split' (type t) (module E : Element.S with type t = t) xs ys =
let rec loop xs ys acc_x acc_y acc_both =
match xs, ys with
| [], [] -> List.(rev acc_x, rev acc_y, rev acc_both)
......@@ -78,7 +81,18 @@ module Data = struct
in
loop xs ys [] [] []
let diff' (type t) (module E : Element.S with type t = t) xs ys =
let diff_split x y =
match x, y with
| Points px, Points py ->
let x, y, xy = diff_split' (module Point) px py in
Ok (Points x, Points y, Points xy)
| Intervals ix, Intervals iy ->
let x, y, xy = diff_split' (module Interval) ix iy in
Ok (Intervals x, Intervals y, Intervals xy)
| _, _ ->
Error `Diffing_points_and_intervals
let diff_seq' (type t) (module E : Element.S with type t = t) xs ys =
let rec take_until elt xs acc =
match xs with
| hd :: tl when E.compare hd elt < 0 ->
......@@ -109,7 +123,22 @@ module Data = struct
in
loop xs ys []
let intersect (type t) (module E : Element.S with type t = t) xs ys =
type 'el diff =
[ `Added of 'el list
| `Equal of 'el list
| `Removed of 'el list
] list
let diff_seq x y =
match x, y with
| Points px, Points py ->
Ok (`Points_diff (diff_seq' (module Point) px py))
| Intervals ix, Intervals iy ->
Ok (`Intervals_diff (diff_seq' (module Interval) ix iy))
| _, _ ->
Error `Diffing_points_and_intervals
let intersect' (type t) (module E : Element.S with type t = t) xs ys =
let rec loop xs ys acc =
match xs, ys with
| [], _ | _, [] ->
......@@ -123,7 +152,7 @@ module Data = struct
in
loop xs ys []
let intersperse (type t) (module E : Element.S with type t = t) xs ys =
let intersperse' (type t) (module E : Element.S with type t = t) xs ys =
let rec loop xs ys acc =
match xs, ys with
| [], [] -> Ok (List.rev acc)
......@@ -140,7 +169,22 @@ module Data = struct
in
loop xs ys []
let intersperse_conflict (type t) (module E : Element.S with type t = t) xs ys =
let intersperse x y =
match x, y with
| Points px, Points py ->
Result.map (intersperse' (module Point) px py)
~f:(fun points -> of_points points)
|> Result.map_error
~f:(function `Overlap (a, b) -> `Points_overlap (a, b))
| Intervals ix, Intervals iy ->
Result.map (intersperse' (module Interval) ix iy)
~f:(fun intervals -> of_intervals intervals)
|> Result.map_error
~f:(function `Overlap (a, b) -> `Intervals_overlap (a, b))
| _, _ ->
Error `Interspersing_points_and_intervals
let intersperse_conflict' (type t) (module E : Element.S with type t = t) xs ys =
let mark_conflict elt =
E.with_text elt (fun s -> "###" ^ s ^ "###") in
let rec loop xs ys acc_x acc_y =
......@@ -159,29 +203,62 @@ module Data = struct
in
loop xs ys [] []
let merge (type t) (module E : Element.S with type t = t) ~old xs ys =
let xs', _, oldx = diff (module E) xs old in
let ys', _, oldy = diff (module E) ys old in
let old' = intersect (module E) oldx oldy
let merge' (type t) (module E : Element.S with type t = t) ~old xs ys =
let xs', _, oldx = diff_split' (module E) xs old in
let ys', _, oldy = diff_split' (module E) ys old in
let old' = intersect' (module E) oldx oldy