Derive scalar changes and composition laws
This commit is contained in:
10 files changed
+527
-3
No files matched your search
+262
@@ -0,0 +1,262 @@
|
||||
type keyed =
|
||||
| CInsert of int * Value.t
|
||||
| CRemove of int * Value.t
|
||||
| CReplace of int * Value.t * Value.t
|
||||
|
||||
type change =
|
||||
| CEmpty
|
||||
| CInt of int
|
||||
| CBool of bool
|
||||
| CString of string
|
||||
| CUnit
|
||||
| CTuple of change list
|
||||
| CRecord of string * (string * change) list
|
||||
| CCollection of keyed list
|
||||
|
||||
let rec is_empty change =
|
||||
match change with
|
||||
| CEmpty -> true
|
||||
| CInt 0 -> true
|
||||
| CTuple items -> List.for_all is_empty items
|
||||
| CRecord (_, fields) -> List.for_all (fun (_, item) -> is_empty item) fields
|
||||
| CCollection items -> items = []
|
||||
| CInt _ | CBool _ | CString _ | CUnit -> false
|
||||
|
||||
let empty _ty = CEmpty
|
||||
|
||||
let int_of span value =
|
||||
match value with
|
||||
| Value.VInt number -> number
|
||||
| other -> Diagnostic.error span "runtime error: expected an integer but got %s" (Value.to_string other)
|
||||
|
||||
let bool_of span value =
|
||||
match value with
|
||||
| Value.VBool truth -> truth
|
||||
| other -> Diagnostic.error span "runtime error: expected a boolean but got %s" (Value.to_string other)
|
||||
|
||||
let string_of_value span value =
|
||||
match value with
|
||||
| Value.VString text -> text
|
||||
| other -> Diagnostic.error span "runtime error: expected a string but got %s" (Value.to_string other)
|
||||
|
||||
let scalar_mismatch span expected value =
|
||||
Diagnostic.error span "this change replaces a %s value but is applied to %s" expected
|
||||
(Value.to_string value)
|
||||
|
||||
let rec apply value change =
|
||||
match change with
|
||||
| CEmpty -> value
|
||||
| CInt delta -> (
|
||||
match value with
|
||||
| Value.VInt current -> Value.VInt (current + delta)
|
||||
| other -> scalar_mismatch Location.none "integer" other)
|
||||
| CBool truth -> (
|
||||
match value with Value.VBool _ -> Value.VBool truth | other -> scalar_mismatch Location.none "boolean" other)
|
||||
| CString text -> (
|
||||
match value with Value.VString _ -> Value.VString text | other -> scalar_mismatch Location.none "string" other)
|
||||
| CUnit -> (
|
||||
match value with Value.VUnit -> Value.VUnit | other -> scalar_mismatch Location.none "unit" other)
|
||||
| CTuple items -> (
|
||||
match value with
|
||||
| Value.VTuple values when List.length values = List.length items ->
|
||||
Value.VTuple (List.map2 apply values items)
|
||||
| _ -> Diagnostic.error Location.none "change does not match the value it is applied to")
|
||||
| CRecord (name, fields) -> (
|
||||
match value with
|
||||
| Value.VRecord (_, values) ->
|
||||
let updated =
|
||||
List.map
|
||||
(fun (label, field_value) ->
|
||||
match Util.assoc_opt label fields with
|
||||
| Some field_change -> (label, apply field_value field_change)
|
||||
| None -> (label, field_value))
|
||||
values
|
||||
in
|
||||
Value.VRecord (name, updated)
|
||||
| _ -> Diagnostic.error Location.none "change does not match the value it is applied to")
|
||||
| CCollection items -> (
|
||||
match value with
|
||||
| Value.VCollection map ->
|
||||
Value.VCollection (apply_keyed map items)
|
||||
| _ -> Diagnostic.error Location.none "change does not match the value it is applied to")
|
||||
|
||||
and apply_keyed map items =
|
||||
List.fold_left
|
||||
(fun map item ->
|
||||
match item with
|
||||
| CInsert (key, value) -> Delta_runtime.Pure_map.add key value map
|
||||
| CRemove (key, _) -> Delta_runtime.Pure_map.remove key map
|
||||
| CReplace (key, _, value) -> Delta_runtime.Pure_map.add key value map)
|
||||
map items
|
||||
|
||||
let rec compose first second =
|
||||
match (first, second) with
|
||||
| CEmpty, other | other, CEmpty -> other
|
||||
| CInt left, CInt right -> CInt (left + right)
|
||||
| CBool _, CBool right -> CBool right
|
||||
| CString _, CString right -> CString right
|
||||
| CUnit, CUnit -> CUnit
|
||||
| CTuple left, CTuple right ->
|
||||
if List.length left <> List.length right then
|
||||
Diagnostic.error Location.none "cannot compose tuple changes of different sizes"
|
||||
else CTuple (List.map2 compose left right)
|
||||
| CRecord (left_name, left_fields), CRecord (right_name, right_fields) ->
|
||||
if left_name <> right_name then
|
||||
Diagnostic.error Location.none "cannot compose changes of different record types"
|
||||
else
|
||||
CRecord
|
||||
( left_name,
|
||||
List.map
|
||||
(fun (label, left_change) ->
|
||||
match Util.assoc_opt label right_fields with
|
||||
| Some right_change -> (label, compose left_change right_change)
|
||||
| None -> (label, left_change))
|
||||
left_fields )
|
||||
| CCollection left, CCollection right ->
|
||||
CCollection (normalize_keyed (left @ right))
|
||||
| _ -> Diagnostic.error Location.none "cannot compose changes of different types"
|
||||
|
||||
and normalize_keyed items =
|
||||
let order = ref [] in
|
||||
let table = Hashtbl.create 16 in
|
||||
List.iter
|
||||
(fun item ->
|
||||
let key =
|
||||
match item with CInsert (key, _) | CRemove (key, _) | CReplace (key, _, _) -> key
|
||||
in
|
||||
match Util.hashtbl_find_opt table key with
|
||||
| None ->
|
||||
Hashtbl.replace table key (old_of item, new_of item);
|
||||
order := key :: !order
|
||||
| Some (old_value, _) -> Hashtbl.replace table key (old_value, new_of item))
|
||||
items;
|
||||
let entries = List.rev !order in
|
||||
Util.filter_map
|
||||
(fun key ->
|
||||
match Util.hashtbl_find_opt table key with
|
||||
| None -> None
|
||||
| Some (old_value, new_value) -> (
|
||||
match (old_value, new_value) with
|
||||
| None, None -> None
|
||||
| None, Some value -> Some (CInsert (key, value))
|
||||
| Some value, None -> Some (CRemove (key, value))
|
||||
| Some old_value, Some new_value ->
|
||||
if old_value = new_value then None else Some (CReplace (key, old_value, new_value))))
|
||||
entries
|
||||
|
||||
and old_of item =
|
||||
match item with CInsert _ -> None | CRemove (_, value) | CReplace (_, value, _) -> Some value
|
||||
|
||||
and new_of item =
|
||||
match item with CInsert (_, value) | CReplace (_, _, value) -> Some value | CRemove _ -> None
|
||||
|
||||
let rec of_values records ty old_value new_value =
|
||||
match Types.repr ty with
|
||||
| Types.TInt -> CInt (int_of Location.none new_value - int_of Location.none old_value)
|
||||
| Types.TBool -> if old_value = new_value then CEmpty else CBool (bool_of Location.none new_value)
|
||||
| Types.TString ->
|
||||
if old_value = new_value then CEmpty else CString (string_of_value Location.none new_value)
|
||||
| Types.TUnit -> CEmpty
|
||||
| Types.TTuple components -> (
|
||||
match (old_value, new_value) with
|
||||
| Value.VTuple old_items, Value.VTuple new_items
|
||||
when List.length old_items = List.length new_items
|
||||
&& List.length components = List.length old_items ->
|
||||
CTuple (List.map2 (fun ty (old_item, new_item) -> of_values records ty old_item new_item)
|
||||
components (List.combine old_items new_items))
|
||||
| _ -> Diagnostic.error Location.none "internal error: tuple change of incompatible values")
|
||||
| Types.TRecord name -> (
|
||||
let fields =
|
||||
match Types.record_info records name with
|
||||
| Some info -> info.Types.ri_fields
|
||||
| None -> Diagnostic.error Location.none "internal error: unknown record %s" name
|
||||
in
|
||||
match (old_value, new_value) with
|
||||
| Value.VRecord (_, old_fields), Value.VRecord (_, new_fields) ->
|
||||
CRecord
|
||||
( name,
|
||||
List.map
|
||||
(fun (label, field_ty) ->
|
||||
match (Util.assoc_opt label old_fields, Util.assoc_opt label new_fields) with
|
||||
| Some old_field, Some new_field -> (label, of_values records field_ty old_field new_field)
|
||||
| _ -> Diagnostic.error Location.none "internal error: record fields do not match")
|
||||
fields )
|
||||
| _ -> Diagnostic.error Location.none "internal error: record change of incompatible values")
|
||||
| Types.TCollection _ -> (
|
||||
match (old_value, new_value) with
|
||||
| Value.VCollection old_map, Value.VCollection new_map ->
|
||||
CCollection (collection_diff old_map new_map)
|
||||
| _ -> Diagnostic.error Location.none "internal error: collection change of incompatible values")
|
||||
| Types.TArrow _ | Types.TVar _ ->
|
||||
Diagnostic.error Location.none "changes are not defined for this type"
|
||||
|
||||
and collection_diff old_map new_map =
|
||||
let keys =
|
||||
List.sort_uniq compare
|
||||
(Delta_runtime.Pure_map.keys old_map @ Delta_runtime.Pure_map.keys new_map)
|
||||
in
|
||||
Util.filter_map
|
||||
(fun key ->
|
||||
match
|
||||
(Delta_runtime.Pure_map.find_opt key old_map, Delta_runtime.Pure_map.find_opt key new_map)
|
||||
with
|
||||
| None, None -> None
|
||||
| None, Some value -> Some (CInsert (key, value))
|
||||
| Some value, None -> Some (CRemove (key, value))
|
||||
| Some old_value, Some new_value ->
|
||||
if old_value = new_value then None else Some (CReplace (key, old_value, new_value)))
|
||||
keys
|
||||
|
||||
let rec equal left right =
|
||||
match (left, right) with
|
||||
| CEmpty, other | other, CEmpty -> is_empty other
|
||||
| CInt a, CInt b -> a = b
|
||||
| CBool a, CBool b -> a = b
|
||||
| CString a, CString b -> a = b
|
||||
| CUnit, CUnit -> true
|
||||
| CTuple a, CTuple b -> List.length a = List.length b && List.for_all2 (fun x y -> equal x y) a b
|
||||
| CRecord (a, fields_a), CRecord (b, fields_b) ->
|
||||
a = b
|
||||
&& List.length fields_a = List.length fields_b
|
||||
&& List.for_all2 (fun (la, ca) (lb, cb) -> la = lb && equal ca cb) fields_a fields_b
|
||||
| CCollection a, CCollection b ->
|
||||
List.length a = List.length b
|
||||
&& List.for_all2
|
||||
(fun x y ->
|
||||
match (x, y) with
|
||||
| CInsert (k1, v1), CInsert (k2, v2) -> k1 = k2 && Value.equal v1 v2
|
||||
| CRemove (k1, v1), CRemove (k2, v2) -> k1 = k2 && Value.equal v1 v2
|
||||
| CReplace (k1, o1, n1), CReplace (k2, o2, n2) ->
|
||||
k1 = k2 && Value.equal o1 o2 && Value.equal n1 n2
|
||||
| _ -> false)
|
||||
a b
|
||||
| _ -> false
|
||||
|
||||
let to_string change =
|
||||
let rec render change =
|
||||
match change with
|
||||
| CEmpty -> "empty"
|
||||
| CInt delta -> Printf.sprintf "+%d" delta
|
||||
| CBool truth -> Printf.sprintf "bool %b" truth
|
||||
| CString text -> Printf.sprintf "string %S" text
|
||||
| CUnit -> "unit"
|
||||
| CTuple items -> "(" ^ Util.join ", " (List.map render items) ^ ")"
|
||||
| CRecord (name, fields) ->
|
||||
name ^ " { "
|
||||
^ Util.join ", " (List.map (fun (label, item) -> label ^ " = " ^ render item) fields)
|
||||
^ " }"
|
||||
| CCollection items ->
|
||||
"collection ["
|
||||
^ Util.join "; "
|
||||
(List.map
|
||||
(fun item ->
|
||||
match item with
|
||||
| CInsert (key, value) -> Printf.sprintf "insert %d %s" key (Value.to_string value)
|
||||
| CRemove (key, value) -> Printf.sprintf "remove %d %s" key (Value.to_string value)
|
||||
| CReplace (key, old_value, new_value) ->
|
||||
Printf.sprintf "replace %d %s %s" key (Value.to_string old_value)
|
||||
(Value.to_string new_value))
|
||||
items)
|
||||
^ "]"
|
||||
in
|
||||
render change
|
||||
@@ -0,0 +1,24 @@
|
||||
type keyed =
|
||||
| CInsert of int * Value.t
|
||||
| CRemove of int * Value.t
|
||||
| CReplace of int * Value.t * Value.t
|
||||
|
||||
type change =
|
||||
| CEmpty
|
||||
| CInt of int
|
||||
| CBool of bool
|
||||
| CString of string
|
||||
| CUnit
|
||||
| CTuple of change list
|
||||
| CRecord of string * (string * change) list
|
||||
| CCollection of keyed list
|
||||
|
||||
val empty : Types.t -> change
|
||||
val is_empty : change -> bool
|
||||
val apply : Value.t -> change -> Value.t
|
||||
val apply_keyed : Value.t Delta_runtime.Pure_map.t -> keyed list -> Value.t Delta_runtime.Pure_map.t
|
||||
val compose : change -> change -> change
|
||||
val normalize_keyed : keyed list -> keyed list
|
||||
val of_values : Types.records -> Types.t -> Value.t -> Value.t -> change
|
||||
val equal : change -> change -> bool
|
||||
val to_string : change -> string
|
||||
+1
-1
@@ -1,5 +1,5 @@
|
||||
let one_line text =
|
||||
match String.index_opt text '\n' with
|
||||
match Util.index_of_char text '\n' with
|
||||
| Some index -> String.sub text 0 index
|
||||
| None -> text
|
||||
|
||||
|
||||
+9
-1
@@ -34,8 +34,16 @@ let rec drop count items =
|
||||
|
||||
let contains value items = List.exists (fun item -> item = value) items
|
||||
|
||||
let index_of_char text character =
|
||||
let rec search index =
|
||||
if index >= String.length text then None
|
||||
else if text.[index] = character then Some index
|
||||
else search (index + 1)
|
||||
in
|
||||
search 0
|
||||
|
||||
let string_before_char text character =
|
||||
match String.index_opt text character with
|
||||
match index_of_char text character with
|
||||
| Some index -> String.sub text 0 index
|
||||
| None -> text
|
||||
|
||||
|
||||
@@ -6,6 +6,7 @@ val list_init : int -> (int -> 'a) -> 'a list
|
||||
val take : int -> 'a list -> 'a list
|
||||
val drop : int -> 'a list -> 'a list
|
||||
val contains : 'a -> 'a list -> bool
|
||||
val index_of_char : string -> char -> int option
|
||||
val string_before_char : string -> char -> string
|
||||
val starts_with : string -> string -> bool
|
||||
val join : string -> string list -> string
|
||||
+13
-1
@@ -35,7 +35,19 @@ let collection_of_list entries =
|
||||
|
||||
let collection_to_list map = Delta_runtime.Pure_map.bindings map
|
||||
|
||||
let equal (left : t) (right : t) = left = right
|
||||
let rec equal (left : t) (right : t) =
|
||||
match (left, right) with
|
||||
| VUnit, VUnit -> true
|
||||
| VInt a, VInt b -> a = b
|
||||
| VBool a, VBool b -> a = b
|
||||
| VString a, VString b -> a = b
|
||||
| VTuple a, VTuple b -> List.length a = List.length b && List.for_all2 equal a b
|
||||
| VRecord (name_a, fields_a), VRecord (name_b, fields_b) ->
|
||||
name_a = name_b
|
||||
&& List.length fields_a = List.length fields_b
|
||||
&& List.for_all2 (fun (label_a, value_a) (label_b, value_b) -> label_a = label_b && equal value_a value_b) fields_a fields_b
|
||||
| VCollection map_a, VCollection map_b -> Delta_runtime.Pure_map.equal equal map_a map_b
|
||||
| _ -> false
|
||||
|
||||
let field record label =
|
||||
match record with
|
||||
|
||||
Reference in new issue
Block a user