(* qq.ml -*- tuareg -*- *) (* Copyright (C) 2026 Tyler Triplett *) (* *) (* This program is free software: you can redistribute it and/or modify *) (* it under the terms of the GNU General Public License as published by *) (* the Free Software Foundation, either version 3 of the License, or *) (* (at your option) any later version. *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU General Public License for more details. *) (* You should have received a copy of the GNU General Public License *) (* along with this program. If not, see <https://www.gnu.org/licenses/>. *) (* Info *) (* A file concatenation program *) (* Mimics functionality of GNU cat *) let help_text = "Usage: qq [OPTION]... [FILE]...\n\ Concatenate FILE(s)\n\n\ <Options>\n\ \032 \027[1;32m-v, --show-nonprinting\027[0m display non printing\n\ \032 \027[1;32m-A\027[0m equal to -vET\n\ \032 \027[1;32m-E, --show-ends\027[0m show $ at end of line\n\ \032 \027[1;32m-e\027[0m equal to -vE\n\ \032 \027[1;32m-T, --show-tabs\027[0m display tabs as ^I\n\ \032 \027[1;32m-t\027[0m equal to -vT\n\ \032 \027[1;32m-n, --number\027[0m number lines\n\ \032 \027[1;32m-b, --number-nonblank\027[0m number non blank lines\n\ \032 \027[1;32m-s, --squeeze-blank\027[0m remove duplicate newlines\n\n\ \032 \027[1;32m --help\027[0m help menu\n\ \032 \027[1;32m --version\027[0m version number\n" let version_text = "Copyright (C) 2026 Tyler Triplett\n\ License GPLv3+: <https://gnu.org/licenses/gpl.html>.\n\ This is free software; see the source for copying conditions. There is NO\n\ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\ \n _______ _______ \n\ | || |\n\ | _ || _ |\n\ | | | || | | |\n\ | |_| || |_| |\n\ | | | |\n\ |____||_||____||_|\n\n\ qq 0.0.1" type 'a continue = | Okay of 'a | BadArg of string | Directory of string | NotFound of string let c_bind (v : 'a continue) (f : 'a -> 'b continue) : 'b continue = match v with | Okay v -> f v | BadArg x -> BadArg x | Directory x -> Directory x | NotFound x -> NotFound x let ( >>= ) = c_bind let c_fmap (v : 'a continue) (f : 'a -> 'b) : 'b continue = match v with | Okay v -> Okay (f v) | BadArg x -> BadArg x | Directory x -> Directory x | NotFound x -> NotFound x let ( <&> ) = c_fmap type flags = | Show | Ends | Tabs | Number | NonBlank | Squeeze | VET | VE | VT | Help | Version type flag = | Full of flags * string * char | Short of flags * char | Terminate of flags * string let valid_flags = [ Full (Show, "--show-nonprinting", 'v'); Full (Ends, "--show-ends", 'E'); Full (Tabs, "--show-tabs", 'T'); Full (Number, "--number", 'n'); Full (NonBlank, "--number-nonblank", 'b'); Full (Squeeze, "--squeeze-blank", 's'); Full (VET, "--show-all", 'A'); Short (VE, 'e'); Short (VT, 't'); Terminate (Help, "--help"); Terminate (Version, "--version"); ] type line_state = { mutable line : int; mutable last_char : char; mutable count : int; } type options = { show : bool; ends : bool; tabs : bool; number : bool; nonblank : bool; squeeze : bool; help : bool; version : bool; } let split_opt = function | "" -> [] | s -> let size = String.length s in let rec go i = if i = size then [] else s.[i] :: go (i + 1) in go 1 let valid_flag v = let abrv_f c = function | Short (_, abrv) -> abrv = c | Full (_, _, abrv) -> abrv = c | _ -> false in let full_p = function | Full (_, full, _) -> full = v | Terminate (_, full) -> full = v | _ -> false in if v.[1] = '-' then List.exists full_p valid_flags else List.for_all (fun x -> List.exists (abrv_f x) valid_flags) @@ split_opt v let flag_get t lst = let match_abrv s a = s.[0] = '-' && s.[1] <> '-' && List.exists (fun c -> c = a) @@ split_opt s in let flag_find = function | Full (_, full, abrv) -> fun x -> x = full || match_abrv x abrv | Short (_, abrv) -> fun x -> match_abrv x abrv | Terminate (_, full) -> fun a -> a = full in let m = function | Terminate (s, _) -> s = t | Short (s, _) -> s = t | Full (s, _, _) -> s = t in let f = List.find m valid_flags |> flag_find in List.exists f lst let control_char c = "^" ^ String.make 1 @@ Char.chr @@ Char.code c + 64 let rec bytes_char c = let code = Char.code c - 128 in if code < 32 then "M-" ^ control_char @@ Char.chr code else if code = 127 then "M-^?" else "M-" ^ String.make 1 @@ Char.chr code type out = | Pchr of char | Pstr of string | Pbuf of Bytes.t * int * int let out_disp = let o_chan = Out_channel.stdout in function | Pchr c -> Out_channel.output_char o_chan c | Pstr s -> Out_channel.output_string o_chan s | Pbuf (b, p, s) -> Out_channel.output o_chan b p s let print_buffer b s options = let { ends; tabs; show } = options in let control_p c = Char.code c < 32 && c <> '\n' && c <> '\t' in let look_p i = i + 1 < s && Bytes.get b (i + 1) = '\n' in let print_char i = out_disp (match (Bytes.get b i) with | '\n' when ends -> Pstr "$\n" | '\t' when tabs -> Pstr (control_char '\t') | '\r' when ends && look_p i -> Pstr "^M" | x when show && control_p x -> Pstr (control_char x) | x when show && Char.code x = 127 -> Pstr "^?" | x when show && Char.code x >= 128 -> Pstr (bytes_char x) | x -> Pchr x) in let rec go i = if i = s then ( () ) else ( print_char i; go @@ i + 1 ) in go 0 let buffer_size = 64 * 1024 let buffer = Bytes.create buffer_size let print_number = let size = 32 in let default = size - 6 in let buffer = Bytes.make size ' ' in let zero = Char.code '0' in let last = size - 1 in let rec fill i n = Bytes.set buffer i (Char.chr ((n mod 10) + zero)); match n / 10 with | 0 -> i | x -> fill (i - 1) x in fun n -> let pos = fill last n |> min default in out_disp @@ Pbuf (buffer, pos, (size - pos)); out_disp @@ Pchr '\t' let chunk i_chan options state = let { number; nonblank; squeeze; } = options in let rec fill_buffer pos = if pos = buffer_size then ( pos ) else ( match In_channel.input_char i_chan with | None -> pos | Some '\n' when squeeze && state.count = 2 -> fill_buffer pos | Some c -> Bytes.set buffer pos c; state.last_char <- c; state.count <- if c = '\n' then state.count + 1 else 0; if c = '\n' && number then pos + 1 else fill_buffer (pos + 1) ) in let rec process_chan add_line_num = let read = fill_buffer 0 in if read <> 0 then ( if add_line_num && (not nonblank || Bytes.get buffer 0 <> '\n') then ( let num = state.line in state.line <- num + 1; print_number num; print_buffer buffer read options; process_chan (Bytes.get buffer (read - 1) = '\n') ) else ( print_buffer buffer read options; process_chan (Bytes.get buffer (read - 1) = '\n' && number) ) ) else ( () ) in process_chan (number && state.last_char = '\n') let read_file path options state = let f = function | "-" -> In_channel.stdin | p -> In_channel.open_bin p in chunk (f path) options state let arg_to_lst args = Array.to_list args |> List.tl let option_p s = String.length s > 1 && s.[0] = '-' let print_error = let bad_argument a = Printf.printf "Bad Argument: '%s'\n'qq --help' for more information\n" a in let directory a = Printf.printf "'%s' Is a directory\n" a in let does_not_exist a = Printf.printf "'%s' Does not exist\n" a in function | BadArg a -> bad_argument a | Directory a -> directory a | NotFound a -> does_not_exist a | _ -> () let has_io_arg = let f = Fun.negate option_p in fun lst -> List.exists f lst let arg_contains f g lst = match List.find_opt f lst with | Some path -> g path | None -> Okay lst let all_exist = let f p = p <> "-" && not @@ Sys.file_exists p in let g s = NotFound s in fun lst -> arg_contains f g lst let any_directory = let f p = p <> "-" && Sys.is_directory p in let g s = Directory s in fun lst -> arg_contains f g lst let any_bad_arguments = let f a = option_p a && not @@ valid_flag a in let g s = BadArg s in fun lst -> arg_contains f g lst let strip_options = let f = Fun.negate option_p in fun lst -> List.filter f lst let read_file_f options files = let state = { line = 1; last_char = '\n'; count = 0; } in let f = fun p -> read_file p options state in List.iter f files let get_options lst = let vET = flag_get VET lst in let vE = flag_get VE lst in let vT = flag_get VT lst in { show = flag_get Show lst || vET || vE || vT; ends = flag_get Ends lst || vET || vE; tabs = flag_get Tabs lst || vET || vT; number = flag_get Number lst || flag_get NonBlank lst; nonblank = flag_get NonBlank lst; squeeze = flag_get Squeeze lst; help = flag_get Help lst; version = flag_get Version lst; } let chain lst options = let m = if not @@ has_io_arg lst then "-" :: lst else lst in (Okay m) >>= any_bad_arguments <&> strip_options >>= all_exist >>= any_directory <&> read_file_f options let run lst = let options = get_options lst in if options.help then ( print_endline help_text; 0 ) else if options.version then ( print_endline version_text; 0 ) else ( let proc = chain lst options in print_error proc; match proc with | Okay _ -> 0 | _ -> 1 ) let () = arg_to_lst Sys.argv |> run |> exit