module Pass_square =

(*  Utilities lens *)
let dels (s:string) = del s s

(************************************************************************
 *                           Regular square lens
 *************************************************************************)

(* Simplest square lens *)
let s = store /[ab]/
let sqr0 =
	let k = key "x" in
	let d = dels "x" in
	[ square k s d ] *
test sqr0 get "xaxxbxxax" = { "x" = "a" }{ "x" = "b" }{ "x" = "a" }
test sqr0 put "xax" after set "/x[3]" "b" = "xaxxbx"

(* test mismatch tag *)
test sqr0 get "xya" = *

(* Test regular expression matching with multiple groups *)
let body = del /([f]+)([f]+)/ "ff" . del /([g]+)([g]+)/ "gg"
let sqr1 =
	let k = key /([a-b]*)([a-b]*)([a-b]*)/ in
	let d1 = del /([a-b]*)([a-b]*)([a-b]*)/ "a" in
	let d2 = del /([x]+)([x]+)/ "xx" in
	[ square k body d1 . d2 ] *

test sqr1 get "aaffggaaxxbbffggbbxx" = { "aa" }{ "bb" }
test sqr1 get "affggaxx" = { "a" }
test sqr1 put "affggaxx" after clear "/b" = "affggaxxbffggbxx"

(* Test XML like elements up to depth 2 *)
let b = del ">" ">" . del /[a-z ]*/ "" . del "</" "</"
let open_tag = key /[a-z]+/
let close_tag = del /[a-z]+/ "a"
let xml = [ del "<" "<" . square open_tag b close_tag . del ">" ">" ] *

let b2 = del ">" ">" . xml . del "</" "</"
let xml2 = [ del "<" "<" . square open_tag b2 close_tag . del ">" ">" ] *

test xml get "<a></a><b></b>" = { "a" }{ "b" }

(* test error on mismatch tag *)
test xml get "<a></a><b></c>" = *

(* test get nested tags of depth 2 *)
test xml2 get "<a><b></b><c></c></a>" =
  { "a"
    { "b" }
    { "c" }
  }

(* test nested put of depth 2 *)
test xml2 put "<a></a>" after clear "/x/y" = "<a></a><x><y></y></x>"

(* test nested put of depth 3 : should fail *)
test xml2 put "<a></a>" after clear "/x/y/z" = *

(* matches can be case-insensitive *)
let s5 = store /[yz]/
let sqr5 =
	let k = key /x/i in
	let d = del /x/i "x" in
	[ square k s5 d ] *
test sqr5 get "xyX" = { "x" = "y" }
test sqr5 get "xyXXyxXyx" = { "x" = "y" }{ "X" = "y" }{ "X" = "y" }
test sqr5 put "xyX" after set "/x[3]" "z" = "xyxxzx"

(* test concat multiple squares *)
let rex = /[a-z]/
let csqr =
	let k = key rex in
	let d = del rex "a" in
	let e = dels "" in
	[ square k e d . square d e d ] *

test csqr get "aabbccdd" = { "a" } { "c" }
test csqr put "aabb" after insa "z" "/a" = "aabbzzaa"

(* test default square create values *)
let create_square =
	let d = dels "a" in
	[ key "x" . square d d d ]*

test create_square put "" after clear "/x" = "xaaa"

(* test optional quotes *)
let word = /[A-Za-z0-9_.-]+/
let entry =
  let k = key word in
  let quote = del /"?/ "\"" (* " *) in
  let body = store /[a-z]+/ in
  let v = square quote body quote in
  [ k . dels "=" . v ]

test entry get "key=\"value\"" = { "key" = "value" }
test entry get "key=value" = { "key" = "value" }

test entry put "key=value" after
  set "/key" "other" = "key=other"

test entry put "key=\"value\"" after
  set "/key" "other" = "key=\"other\""

(* create with square *)
(* Passing this test successfully requires that the skeleton from the get *)
(* is correctly detected as not matching the skeleton for the second lens *)
(* in hte union - the reason for the mismatch is that the quote is        *)
(* optional in the first branch of the union, and the skeleton therefore  *)
(* does not have "@" in the right places, triggering a create             *)
let sq_create =
  let word = store /[a-z]+/ in
  let number = store /[0-9]+/ in
  let quot = dels "@" in
  let quot_opt = del /@?/ "@" in
    [ label "t" . square quot_opt word quot_opt ]
  | [ label "t" . square quot number quot ]

test sq_create put "abc" after
  set "/t" "42" = "@42@"