From 2001851983d5cd8ed7f25a62e066f09758c67ab1 Mon Sep 17 00:00:00 2001
From: toastal <toastal@posteo.net>
Date: Thu, 23 Feb 2023 19:41:20 +0700
Subject: [PATCH] Add ocamlformat (wrapped with tab support)

---
 flake.nix                                    | 29 ++++++-
 srht_markup_massager/.ocamlformat            | 14 ++++
 srht_markup_massager/srht_markup_massager.ml | 83 +++++++++-----------
 3 files changed, 80 insertions(+), 46 deletions(-)
 create mode 100644 srht_markup_massager/.ocamlformat

diff --git a/flake.nix b/flake.nix
index 8e32274..0a07143 100755
--- a/flake.nix
+++ b/flake.nix
@@ -15,11 +15,35 @@
 
       nixpkgsFor = forAllSystems (system: import nixpkgs {
         inherit system;
-        overlays = [ self.overlay ];
+        overlays = [ self.overlay.default ];
       });
     in
     {
-      overlay = final: prev: { };
+      overlay.default = final: prev:
+        let
+          appendFlags = new: old:
+            with builtins;
+            if isString old then prev.lib.concatStringsSep " " ([ old ] ++ new)
+            else if isList old then prev.lib.concatStringsSep " " (old ++ new)
+            else (prev.lib.concatStringsSep " " new);
+
+          of = prev.ocamlformat.overrideAttrs (old: {
+            flambdaSupport = true;
+            configureFlags = appendFlags [ "-O3" ] (old.configureFlags or null);
+          });
+        in
+        {
+          ocamlformat-with-tabs = prev.symlinkJoin {
+            name = "ocamlformat";
+            paths = [
+              (prev.writeShellScriptBin "ocamlformat" ''
+                set -euo pipefail
+                exec ${prev.lib.getExe of} "$@" | unexpand --first-only --tabs=2
+              '')
+              of
+            ];
+          };
+        };
 
       defaultPackage = forAllSystems (system: self.packages.${system}.${name});
 
@@ -73,6 +97,7 @@
           buildInputs = with pkgs; [
             dhall
             nixpkgs-fmt
+            ocamlformat-with-tabs
           ];
           inputsFrom = builtins.attrValues self.packages.${system};
         });
diff --git a/srht_markup_massager/.ocamlformat b/srht_markup_massager/.ocamlformat
new file mode 100644
index 0000000..030dd1a
--- /dev/null
+++ b/srht_markup_massager/.ocamlformat
@@ -0,0 +1,14 @@
+profile = ocamlformat
+break-fun-sig = fit-or-vertical
+cases-exp-indent = 2
+cases-matching-exp-indent = compact
+field-space = loose
+function-indent = 2
+margin = 90
+nested-match = align
+leading-nested-match-parens = false
+space-around-arrays = true
+space-around-lists = true
+space-around-records = true
+space-around-variants = true
+wrap-comments = true
diff --git a/srht_markup_massager/srht_markup_massager.ml b/srht_markup_massager/srht_markup_massager.ml
index b0a6214..cca9bbe 100755
--- a/srht_markup_massager/srht_markup_massager.ml
+++ b/srht_markup_massager/srht_markup_massager.ml
@@ -1,7 +1,5 @@
-(*
-	SPDX-FileCopyrightText 2022 toastal <toastal@posteo.net>
-	SPDX-License-Identifier: LGPL-2.1-or-later
-*)
+(* SPDX-FileCopyrightText 2022 toastal <toastal@posteo.net> SPDX-License-Identifier:
+	 LGPL-2.1-or-later *)
 let unicon node =
 	let () = Soup.remove_class "icon" node in
 	Soup.add_class "Icon" node
@@ -11,43 +9,43 @@ let mk_del node =
 	Soup.set_name "del" node
 
 let unwrap_lone_p soup parent_selector =
-	Soup.select (String.concat "" [ parent_selector; ">"; "p:only-child" ]) soup
+	soup
+	|> Soup.select (String.concat "" [ parent_selector; ">"; "p:only-child" ])
 	|> Soup.iter Soup.unwrap
 
 let unwrap_definition_list_items node =
 	match Soup.parent node with
+	| None ->
+		()
 	| Some parent ->
 		match Soup.parent parent with
 		| Some parent' ->
 			let () = Soup.select "li" node |> Soup.iter (Soup.set_name "dd") in
 			let () = Soup.replace parent' node in
 			Soup.unwrap node
-		| None -> ()
-	| None -> ()
+		| None ->
+			()
 
 let markdown_wrapper node =
-	let wrapper = Soup.create_element  ~class_:"markdown" "div" in
+	let wrapper = Soup.create_element ~class_:"markdown" "div" in
 	Soup.wrap node wrapper
 
 let aside_n_color_admonitions node =
 	(* `aside` is a more semantic element *)
-	(* SourceHut doesn’t support <aside> even if it is more semantic
-	let () = Soup.set_name "aside" node in
-	*)
+	(* SourceHut doesn’t support <aside> even if it is more semantic let () = Soup.set_name
+		 "aside" node in *)
 	let add_icon_class c = Soup.select ".Icon" node |> Soup.iter (Soup.add_class c) in
 	let cs = Soup.classes node in
-	if List.exists (fun x -> x = "tip" || x = "info") cs then
-		add_icon_class "bg-info"
+	if List.exists (fun x -> x = "tip" || x = "info") cs then add_icon_class "bg-info"
 	else if List.exists (fun x -> x = "caution" || x = "warning") cs then
 		add_icon_class "bg-warning"
-	else if List.exists (fun x -> x = "important") cs then
-		add_icon_class "bg-danger"
+	else if List.exists (fun x -> x = "important") cs then add_icon_class "bg-danger"
 
-(* `pygments.rb` Gem isn’t upstreamed into Nixpkgs, and it looks
- * complicated to do so. Errors are being swallowed; lazy. *)
+(* `pygments.rb` Gem isn’t upstreamed into Nixpkgs, and it looks complicated to do so.
+	 Errors are being swallowed; lazy. *)
 let pygmentize_element node =
-	match Soup.attribute "data-lang" node, Soup.leaf_text node, Soup.parent node with
-	| (Some lang, Some sauce, Some parent) ->
+	match (Soup.attribute "data-lang" node, Soup.leaf_text node, Soup.parent node) with
+	| Some lang, Some sauce, Some parent ->
 		(* These syntaxes aren’t yet supported *)
 		let lang' =
 			if lang = "purescript" || lang = "dhall" then "haskell"
@@ -55,10 +53,11 @@ let pygmentize_element node =
 			else lang
 		in
 		let command = Printf.sprintf "pygmentize -f html -l %s" lang' in
-		let std_out, std_in, std_err =
-			Unix.open_process_full command (Unix.environment ())
+		let std_out, std_in, std_err = Unix.open_process_full command (Unix.environment ()) in
+		let () =
+			Soup.write_channel std_in sauce ;
+			flush std_in
 		in
-		let () = Soup.write_channel std_in sauce; flush std_in in
 		(* close stdin to signal the end of input *)
 		let () = close_out std_in in
 		let output = Soup.read_channel std_out in
@@ -68,54 +67,50 @@ let pygmentize_element node =
 		let () =
 			Soup.select "div.highlight" parsed_code
 			|> Soup.iter (fun cont ->
-					let () = Soup.set_attribute "data-lang" lang cont in
-					if lang != lang' then Soup.set_attribute "data-alt-lexer" lang' cont
-				)
+						 let () = Soup.set_attribute "data-lang" lang cont in
+						 if lang != lang' then Soup.set_attribute "data-alt-lexer" lang' cont )
 		in
-		let () = (* special code cleanup *)
+		let () =
+			(* special code cleanup *)
 			if lang' = "nix" then
 				let remove_false_positive_errors er =
-					if (Soup.texts er) = ["$"] then
+					if Soup.texts er = [ "$" ] then
 						match Soup.next_sibling er with
-						| Some ns when (Soup.texts ns) = ["{"] ->
+						| Some ns when Soup.texts ns = [ "{" ] ->
 							let () = Soup.remove_class "err" er in
 							Soup.add_class "p" er
-						| _ -> ()
+						| _ ->
+							()
 				in
 				Soup.select "span.err" parsed_code |> Soup.iter remove_false_positive_errors
 			else ()
 		in
 		Soup.replace parent parsed_code
 	(* yeah, this is lazy *)
-	| (_, _, _) -> ()
+	| _, _, _ ->
+		()
 
 let () =
 	let soup = Soup.read_channel stdin |> Soup.parse in
 	(* Admonitions contain incompatible class *)
 	let () = Soup.select "td.icon" soup |> Soup.iter unicon in
-	(* Personally I think these are bugs in Asciidoctor, but visually it
-	adds unnecessary space *)
+	(* Personally I think these are bugs in Asciidoctor, but visually it adds unnecessary
+		 space *)
 	let () = List.iter (unwrap_lone_p soup) [ "dd"; "li"; "th"; "td" ] in
-	(* Personally I think this is bug in Asciidoctor, as this is the
-	wrong element *)
+	(* Personally I think this is bug in Asciidoctor, as this is the wrong element *)
 	let () = Soup.select "span.line-through" soup |> Soup.iter mk_del in
 	(* `markdown` class needed to get borders and padding *)
 	let () = Soup.select "table" soup |> Soup.iter markdown_wrapper in
-	(* Personally I think this is another bug in Asciidoctor, as you
-	can’t make multiple `<dd>`s *)
+	(* Personally I think this is another bug in Asciidoctor, as you can’t make multiple
+		 `<dd>`s *)
 	let () =
 		Soup.select "dl > dd > div.ulist:only-child > ul:only-child" soup
 		|> Soup.iter unwrap_definition_list_items
 	in
 	(* Admonitions need a lot of love on various platforms *)
+	let () = Soup.select ".admonitionblock" soup |> Soup.iter aside_n_color_admonitions in
+	(* Run source blocks through `pygmentize` to emulate the Python Markdown toolchain *)
 	let () =
-		Soup.select ".admonitionblock" soup
-		|> Soup.iter aside_n_color_admonitions
-	in
-	(* Run source blocks through `pygmentize` to emulate the Python
-	Markdown toolchain *)
-	let () =
-		Soup.select "pre.highlight code[data-lang]" soup
-		|> Soup.iter pygmentize_element
+		Soup.select "pre.highlight code[data-lang]" soup |> Soup.iter pygmentize_element
 	in
 	soup |> Soup.to_string |> Soup.write_channel stdout
-- 
2.45.2