OCaml: Implement log contexts

ocaml/README.md

@@ -33,6 +33,7 @@ In this grammar, `digit` implies `decimal digit`. Spaces between the key and the
             - [x] Handle checking `su -c` default with `which` when `tori.conf` exists but `su_command` is absent in it
             - [x] Properly handle a compose `su_command` such as `su -c` in `System.Package`
             - [x] Properly handle dependent options
+            - [x] Implement log levels
             - [ ] Write tests
         - [x] Validation
             - [x] Valid path or in `PATH`

ocaml/dune-workspace

@@ -1,4 +1,4 @@
 (lang dune 3.17)
 (context default)
 
-(env (dev (flags (:standard -w +A-23-40-42))))
+(env (dev (flags (:standard -w +A-23-40-42-48-70))))

ocaml/lib/parsers/argument.ml

@@ -23,7 +23,7 @@ let interpret (past : Schema.schema) (arguments : string list) : Schema.schema =
             {
               past.output with
               main =
-                "Unknown command: " ^ head ^ "\n" ^ past.meta.help.short;
+                "Unrecognized command: " ^ head ^ "\n" ^ past.meta.help.short;
             };
           meta = { past.meta with status = 1 };
         }

ocaml/lib/parsers/config/lexer.ml

@@ -98,5 +98,5 @@ let scan_line (input: char list): token list =
 
 let scan (char_lists: char lists): token lists =
     let tokens = rmap (scan_line) char_lists $: [End] in
-    elog $ string_of_tokens tokens;
+    elog ~context:Parsing $ string_of_tokens tokens;
     tokens

ocaml/lib/parsers/config/parser.ml

@@ -1,14 +1,8 @@
-(* open Utilities.Aliases *)
 open Lexer
 open Utilities.Aliases
 
 let default_config: Schema.main = Schema.origin.input.configuration.main
 
-(*
-    TODO: The `elog` calls in this module's functions cause cram tests
-    to fail. Separate logging levels can be implemented to solve this.
-*)
-
 let parse_boolean (key: key) (value: string): Schema.default_bool =
     match value with
     | "true" -> true
@@ -16,7 +10,7 @@ let parse_boolean (key: key) (value: string): Schema.default_bool =
     | _ -> raise $ Malformed_source
         (Schema.string_of_key key ^ " must be either true or false")
 
-let check_sanity (config: Schema.main): Schema.main =
+let check (config: Schema.main): Schema.main =
 
     let default = Schema.origin.input.configuration.main in
 
@@ -24,20 +18,20 @@ let check_sanity (config: Schema.main): Schema.main =
        and default to unquoted if a custom su_command is set *)
     match config.su_command_quoted, config.su_command with
     | (true|false), su_command when su_command == default.su_command ->
-        elog $ "[c.parser.check_sanity] " ^
+        elog ~context:Parsing $ "[c.parser.check] " ^
         "Ignoring configuration key su_command_quoted: su_command is unset," ^
         " and the default su_command needs quoting";
         { config with su_command_quoted = default.su_command_quoted }
     | (true|false), _ -> config
     | Default, su_command when su_command <> default.su_command ->
-        elog $ "[c.parser.check_sanity] " ^
+        elog ~context:Parsing $ "[c.parser.check] " ^
         "Setting su_command_quoted to false: su_command is set, but " ^
         "su_command_quoted isn't. If it needs quoting, please set it to true";
         { config with su_command_quoted = false }
     | Default, _ -> config
 
 let update config key (value: string): Schema.main =
-    elog $ "[c.parser.update] Matching value '" ^ value ^ "'";
+    elog ~context:Parsing $ "[c.parser.update] Matching value '" ^ value ^ "'";
     match key with
     | Schema.SuCommand ->
         { config with Schema.su_command = String.split_on_char ' ' value }
@@ -45,7 +39,7 @@ let update config key (value: string): Schema.main =
         { config with
             Schema.su_command_quoted = parse_boolean key value }
     | Unknown ->
-        elog $ "[c.parser.update] Dropped value: unknown key";
+        elog ~context:Parsing $ "[c.parser.update] Dropped value: unknown key";
         config
 
 let parse tokens: Schema.main =
@@ -53,23 +47,25 @@ let parse tokens: Schema.main =
         match tokens with
         | [] -> config
         | Key key :: tail ->
-            elog $ "[c.parser.parse ] Picked key '" ^
+            elog ~context:Parsing $ "[c.parser.parse] Picked key '" ^
                 Schema.string_of_key key ^ "'";
             parse_tokens tail config (Some key)
         | Value value :: tail ->
-            elog $ "[c.parser.parse ] Picked value '" ^ value ^ "'";
+            elog ~context:Parsing $
+            "[c.parser.parse] Picked value '" ^ value ^ "'";
             (match ready_key with
                 | Some key -> parse_tokens tail (update config key value) None
                 | None -> raise $ Malformed_source "Value lacks preceding key")
         | Unknown char :: tail ->
-            elog $ "[c.parser.parse ] Dropping unknown token " ^ str_char char;
+            elog ~context:Parsing $
+            "[c.parser.parse] Dropping unknown token " ^ str_char char;
             parse_tokens tail config ready_key
         | (Space|Equal|LineBreak|End) :: tail ->
             parse_tokens tail config ready_key
 
     in
     parse_tokens tokens default_config None
-    |> check_sanity
+    |> check
 
 let apply (origin: Schema.schema) (config: Schema.main): Schema.schema =
     { origin with input = {

ocaml/lib/system/os.ml

@@ -2,7 +2,7 @@
 
 let identify : string =
     let os_release = String.split_on_char '\n' (File.read "/etc/os-release") in
-    Utilities.Log.elog (String.concat "\n" os_release);
+    Utilities.Log.elog ~context:OS (String.concat "\n" os_release);
 
     let os_equals = List.find (String.starts_with ~prefix:"NAME=") os_release in
     match String.split_on_char '=' os_equals with

ocaml/lib/utilities/log.ml

@@ -1,4 +1,11 @@
-let elog (message : string) : unit =
-    let debug_flag = try Unix.getenv "DEBUG" with Not_found -> "" in
+type context = Default | OS | Parsing
 
-    if debug_flag <> "" then prerr_endline @@ " [log] " ^ message
+let elog ?(context: context option) (message : string) : unit =
+
+    let debug_flag = try Unix.getenv "DEBUG" with Not_found -> "" in
+    let log () = prerr_endline @@ " [log] " ^ message in
+
+    match context with
+    | None | Some Default -> if debug_flag <> "" then log ()
+    | Some Parsing -> if debug_flag = "parsing" then log ()
+    | Some OS -> if debug_flag = "os" then log ()

ocaml/test/cram.t

@@ -3,7 +3,7 @@ This file tests this tori implementation against the Iganaq Napkin Spec v0.2
 A2. 'log' MUST print only if DEBUG is set and MUST be preceded by ' [log] '
 
   $ without_debug=$(tori os 2>&1)
-  $ with_debug=$(DEBUG=1 tori os 2>&1)
+  $ with_debug=$(DEBUG=os tori os 2>&1)
   $ test "$without_debug" != "$with_debug"
   $ echo "$with_debug" | grep -Fq " [log] "
   $ echo "$without_debug" | grep -Fqv " [log] "
@@ -12,9 +12,9 @@ A3.4. [config] su_command must be validated for presence at the provided path
 or a path obtained from $PATH and filesystem permission to execute
 
   $ echo 'su_command=sudo' > $HOME/.config/tori/tori.conf
-  $ ! which sudo >/dev/null || tori smoke 2>&1 >/dev/null
+  $ ! which sudo >/dev/null || tori 2>&1 >/dev/null
   $ echo 'su_command=doas' > $HOME/.config/tori/tori.conf
-  $ ! which doas >/dev/null || tori smoke 2>&1 >/dev/null
+  $ ! which doas >/dev/null || tori 2>&1 >/dev/null
 
 B2.1. version | -v | --version -> MUST print the version as in v0.8.0
 
@@ -48,7 +48,7 @@ B2.3. os -> MUST print the os name
 
 B2.3. os -> MUST log the contents of /etc/os-release
 
-  $ tori_os=$(DEBUG=1 tori os 2>&1)
+  $ tori_os=$(DEBUG=os tori os 2>&1)
   $ test -n "$tori_os"
   $ echo "$tori_os" | grep -qFf /etc/os-release