From c835f992fd0394d74a6f82b6d1edd9713fd6d076 Mon Sep 17 00:00:00 2001
From: sneeker <s@cpl0.zip>
Date: Fri, 1 Mar 2019 05:48:41 +0000
Subject: [PATCH] Handle list head and tail updates with explicit empty-list
 errors

---
 README.md      |  2 ++
 fieldglass.ml  | 12 ++++++++++++
 fieldglass.mli |  2 ++
 runtime.ml     | 10 ++++++++++
 4 files changed, 26 insertions(+)

diff --git a/README.md b/README.md
index ba482fe..40c2f64 100644
--- a/README.md
+++ b/README.md
@@ -3,3 +3,5 @@
 Lenses for reading and updating immutable data in OCaml.
 
 Build with `make`; run the checks with `make test`.
+
+The `_hd` and `_tl` lenses raise `Invalid_argument` on empty lists.
diff --git a/fieldglass.ml b/fieldglass.ml
index d275190..6141064 100644
--- a/fieldglass.ml
+++ b/fieldglass.ml
@@ -13,3 +13,15 @@ let compose (outer_get, outer_put) (inner_get, inner_put) =
 let _1 = (fun (left, _) -> left), (fun left (_, right) -> left, right)
 let _2 = (fun (_, right) -> right), (fun right (left, _) -> left, right)
 let _id = (fun value -> value), (fun value _ -> value)
+
+let split = function
+  | head :: tail -> head, tail
+  | [] -> invalid_arg "Fieldglass: empty list"
+
+let _hd =
+  (fun source -> fst (split source)),
+  (fun head source -> head :: snd (split source))
+
+let _tl =
+  (fun source -> snd (split source)),
+  (fun tail source -> fst (split source) :: tail)
diff --git a/fieldglass.mli b/fieldglass.mli
index 78af4db..e7d0452 100644
--- a/fieldglass.mli
+++ b/fieldglass.mli
@@ -9,3 +9,5 @@ val compose : ('s, 't, 'a, 'b) lens -> ('a, 'b, 'c, 'd) lens -> ('s, 't, 'c, 'd)
 val _1 : ('a * 'c, 'b * 'c, 'a, 'b) lens
 val _2 : ('c * 'a, 'c * 'b, 'a, 'b) lens
 val _id : ('a, 'b, 'a, 'b) lens
+val _hd : ('a list, 'a) lens'
+val _tl : ('a list, 'a list) lens'
diff --git a/runtime.ml b/runtime.ml
index b5d2b51..50555f0 100644
--- a/runtime.ml
+++ b/runtime.ml
@@ -30,3 +30,13 @@ let () =
   assert (set _id "grey" 9 = "grey");
   assert (view (compose _id _1) (9, false) = view _1 (9, false));
   assert (set (compose _2 _id) "grey" (true, 9) = set _2 "grey" (true, 9))
+
+let () =
+  assert (view _hd [1; 2] = 1);
+  assert (view _tl [1] = []);
+  assert (set _hd 3 [1; 2] = [3; 2]);
+  assert (set _tl [3; 4] [1; 2] = [1; 3; 4]);
+  List.iter (fun action ->
+    try action (); assert false with Invalid_argument _ -> ())
+    [(fun () -> ignore (view _hd [])); (fun () -> ignore (view _tl []));
+     (fun () -> ignore (set _hd 1 [])); (fun () -> ignore (set _tl [] []))]