├── bugs ├── templates │ ├── edit │ ├── reopen │ ├── merge │ ├── autoclose │ ├── close │ └── add ├── done │ ├── 950bffde2994_broken_autoclose │ ├── 0001_Detect_existing_postcommit_hook │ ├── 0002_Bug_number_conflicts_when_merging_repos │ └── 9502f97e2994_autoclose_should_ignore_closed_bugs_in_abbreviated_id_resolution ├── open │ └── 257da20f2994_autoclose_called_when_rebasing └── all │ ├── 950bffde2994_broken_autoclose │ ├── 9502f97e2994_autoclose_should_ignore_closed_bugs_in_abbreviated_id_resolution │ ├── 0001_Detect_existing_postcommit_hook │ ├── 257da20f2994_autoclose_called_when_rebasing │ └── 0002_Bug_number_conflicts_when_merging_repos ├── .gitignore ├── OMakeroot ├── src ├── OMakefile ├── gitbug.ml └── prelude.ml ├── OMakefile ├── LICENSE └── README /bugs/templates/edit: -------------------------------------------------------------------------------- 1 | 2 | -- edited by %USER% on %TIMESTAMP% 3 | 4 | -------------------------------------------------------------------------------- /bugs/templates/reopen: -------------------------------------------------------------------------------- 1 | 2 | -- reopened by %USER% on %TIMESTAMP% 3 | 4 | -------------------------------------------------------------------------------- /bugs/done/950bffde2994_broken_autoclose: -------------------------------------------------------------------------------- 1 | ../all/950bffde2994_broken_autoclose -------------------------------------------------------------------------------- /bugs/templates/merge: -------------------------------------------------------------------------------- 1 | 2 | -- merged with %NAME% by %USER% on %TIMESTAMP% 3 | 4 | -------------------------------------------------------------------------------- /bugs/templates/autoclose: -------------------------------------------------------------------------------- 1 | 2 | -- closed by %USER% on %TIMESTAMP% 3 | 4 | FIXED 5 | 6 | -------------------------------------------------------------------------------- /bugs/done/0001_Detect_existing_postcommit_hook: -------------------------------------------------------------------------------- 1 | ../all/0001_Detect_existing_postcommit_hook -------------------------------------------------------------------------------- /bugs/open/257da20f2994_autoclose_called_when_rebasing: -------------------------------------------------------------------------------- 1 | ../all/257da20f2994_autoclose_called_when_rebasing -------------------------------------------------------------------------------- /bugs/done/0002_Bug_number_conflicts_when_merging_repos: -------------------------------------------------------------------------------- 1 | ../all/0002_Bug_number_conflicts_when_merging_repos -------------------------------------------------------------------------------- /bugs/templates/close: -------------------------------------------------------------------------------- 1 | 2 | -- closed by %USER% on %TIMESTAMP% 3 | 4 | FIXED 5 | WONTFIX 6 | NOTABUG 7 | DUPLICATE 8 | 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.* 2 | /*/.* 3 | *.cmi 4 | *.cmx 5 | *.cmxa 6 | *.o 7 | *.a 8 | *.omc 9 | gitbug 10 | gitbug.opt 11 | 12 | 13 | -------------------------------------------------------------------------------- /bugs/templates/add: -------------------------------------------------------------------------------- 1 | -- opened by %USER% on %TIMESTAMP% 2 | 3 | Problem description: 4 | 5 | How to reproduce: 6 | 7 | Proposed solution: 8 | -------------------------------------------------------------------------------- /bugs/done/9502f97e2994_autoclose_should_ignore_closed_bugs_in_abbreviated_id_resolution: -------------------------------------------------------------------------------- 1 | ../all/9502f97e2994_autoclose_should_ignore_closed_bugs_in_abbreviated_id_resolution -------------------------------------------------------------------------------- /OMakeroot: -------------------------------------------------------------------------------- 1 | open build/C 2 | open build/OCaml 3 | open build/LaTeX 4 | 5 | # The command-line variables are defined *after* the 6 | # standard configuration has been loaded. 7 | DefineCommandVars() 8 | 9 | # Include the OMakefile in this directory. 10 | .SUBDIRS: . 11 | -------------------------------------------------------------------------------- /src/OMakefile: -------------------------------------------------------------------------------- 1 | NATIVE_ENABLED = true 2 | 3 | USE_OCAMLFIND = true 4 | 5 | OCAMLPACKS[] = unix pcre netstring 6 | OCamlLibrary(gitbug, prelude gitbug) 7 | 8 | .DEFAULT: gitbug.cmxa 9 | 10 | .PHONY: clean 11 | 12 | clean: 13 | rm -f $(filter-proper-targets $(ls R, .)) 14 | 15 | -------------------------------------------------------------------------------- /bugs/all/950bffde2994_broken_autoclose: -------------------------------------------------------------------------------- 1 | title: broken autoclose 2 | status: CLOSED 3 | reported by: 4 | date: 2009-02-11 16:25:51+0100 5 | author: Mauricio Fernandez 6 | assigned to: 7 | 8 | -- opened by Mauricio Fernandez on 2009-02-11 16:25:51+0100 9 | 10 | Problem description: 11 | 12 | FIXED: [id] doesn't work as it should. 13 | -- closed by Mauricio Fernandez on 2009-02-11 16:29:34+0100 14 | 15 | FIXED 16 | 17 | -------------------------------------------------------------------------------- /bugs/all/9502f97e2994_autoclose_should_ignore_closed_bugs_in_abbreviated_id_resolution: -------------------------------------------------------------------------------- 1 | title: autoclose should ignore closed bugs in abbreviated id resolution 2 | status: CLOSED 3 | reported by: 4 | date: 2009-02-11 15:58:39+0100 5 | author: Mauricio Fernandez 6 | assigned to: 7 | 8 | -- opened by Mauricio Fernandez on 2009-02-11 15:58:39+0100 9 | 10 | Problem description: 11 | 12 | gitbugs looks for a unique match in all/, when open/ suffices. 13 | 14 | -- closed by Mauricio Fernandez on 2009-02-11 16:28:04+0100 15 | 16 | FIXED 17 | 18 | -------------------------------------------------------------------------------- /bugs/all/0001_Detect_existing_postcommit_hook: -------------------------------------------------------------------------------- 1 | title: Detect existing post-commit hook 2 | status: CLOSED 3 | date: 2008-09-18 00:48:51+0300 4 | author: Ilmari Heikkinen 5 | 6 | -- opened by Ilmari Heikkinen on 2008-09-18 00:48:51+0300 7 | 8 | Problem description: 9 | gitbug init or gitbug use_autoclose 10 | can screw up an existing post-commit hook 11 | 12 | Proposed solution: 13 | Check whether there exists a post-commit hook, 14 | tell user to add the autoclose to the hook manually. 15 | -- closed by Ilmari Heikkinen on 2008-09-18 01:13:55+0300 16 | 17 | FIXED 18 | 19 | -------------------------------------------------------------------------------- /bugs/all/257da20f2994_autoclose_called_when_rebasing: -------------------------------------------------------------------------------- 1 | title: autoclose called when rebasing, leading to conflicts 2 | status: OPEN 3 | reported by: 4 | date: 2009-02-11 16:35:06+0100 5 | author: Mauricio Fernandez 6 | assigned to: 7 | 8 | -- opened by Mauricio Fernandez on 2009-02-11 16:35:06+0100 9 | 10 | Problem description: 11 | 12 | When doing a rebase, autoclose kicks in after each commit is re-applied, 13 | resulting in a conflict in the bug (different close date). 14 | 15 | How to reproduce: 16 | 17 | git rebase -i some_commit_before_an_autoclosed_bug 18 | 19 | Proposed solution: 20 | 21 | Somehow detect when we're in the middle of a rebase. git knows that, so it 22 | must be creating some file in .git. 23 | -------------------------------------------------------------------------------- /OMakefile: -------------------------------------------------------------------------------- 1 | NATIVE_ENABLED = true 2 | 3 | USE_OCAMLFIND = true 4 | 5 | .PHONY: clean 6 | clean: 7 | rm -f *.cmi *.cmo *.cmx *.cmxa *.cma *.annot *.s *.o *.opt \ 8 | *.run *.a *.inc 9 | 10 | %.sig: %.ml %.cmo 11 | $(OCAMLFIND) $(OCAMLC) -package $(concat \,, $(OCAMLPACKS)) \ 12 | $(mapprefix -I, $(OCAMLINCLUDES)) \ 13 | $(OCAMLFLAGS) $(OCAMLCFLAGS) -i $< > $@ 14 | 15 | if $(not $(defined-env TEST)) 16 | OCAMLFLAGS = -g 17 | OCAMLCFLAGS += -dtypes 18 | OCAML_BYTE_LINK_FLAGS = -g 19 | 20 | if $(not $(OCAMLFIND_EXISTS)) 21 | eprintln(This project requires ocamlfind, but is was not found.) 22 | eprintln(You need to install ocamlfind and run "omake --configure".) 23 | exit 1 24 | 25 | OCAMLCFLAGS += -dtypes 26 | 27 | .SUBDIRS: src 28 | 29 | section 30 | OCAMLPACKS[] = pcre unix netstring 31 | OCamlProgram(gitbug, src/prelude src/gitbug) 32 | 33 | .DEFAULT: gitbug$(EXE) 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Gitbug: In-repo bug tracker for Git. 2 | 3 | Copyright (C) 2008 Ilmari Heikkinen 4 | Mauricio Fernandez 5 | 6 | Permission is hereby granted, free of charge, to any person 7 | obtaining a copy of this software and associated documentation 8 | files (the "Software"), to deal in the Software without 9 | restriction, including without limitation the rights to use, 10 | copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the 12 | Software is furnished to do so, subject to the following 13 | conditions: 14 | 15 | The above copyright notice and this permission notice shall be 16 | included in all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 19 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 20 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 21 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 22 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 23 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 24 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 25 | OTHER DEALINGS IN THE SOFTWARE. 26 | -------------------------------------------------------------------------------- /bugs/all/0002_Bug_number_conflicts_when_merging_repos: -------------------------------------------------------------------------------- 1 | title: Bug number conflicts when merging repos 2 | status: CLOSED 3 | date: 2008-09-18 00:50:41+0300 4 | author: Ilmari Heikkinen 5 | 6 | -- opened by Ilmari Heikkinen on 2008-09-18 00:50:41+0300 7 | 8 | Problem description: 9 | Merging two repositories with new bugs added will cause several 10 | bugs with the same id. 11 | 12 | How to reproduce: 13 | git checkout -b foo 14 | gitbug add foo 15 | git checkout master 16 | gitbug add bar 17 | git merge foo 18 | tree bugs 19 | bugs 20 | |-- all 21 | | |-- 0001_bar 22 | | `-- 0001_foo 23 | 24 | 25 | Proposed solution: 26 | Use truncated hash? 27 | 28 | -- edited by Ilmari Heikkinen on 2008-09-18 01:27:13+0300 29 | 30 | Eridius on #ocaml had the following idea: 31 | Use a truncated hash internally. 32 | FIX[x] in commit message references to either unique hash prefix or 33 | position on current open list (list should print stable position numbers.) 34 | Have a commit-msg hook that edits FIX[x] into FIX[hash] 35 | -- closed by Ilmari Heikkinen on 2009-02-10 20:30:48+0200 36 | 37 | FIXED 38 | 39 | using a 6-byte timestamp now, it won't collide as easily 40 | but it's a usability nightmare 41 | 42 | 43 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Gitbug is an in-repo bug tracker for Git repositories. 2 | 3 | 4 | Installation: 5 | 6 | 0. Install ocamlfind, omake and the OCaml libraries pcre and netstring. 7 | On a Debian/Ubuntu: 8 | $ sudo apt-get install libocamlnet-ocaml-dev libpcre-ocaml-dev omake ocaml-findlib 9 | 10 | 1. Compile 11 | $ omake 12 | 13 | 2. Copy the executable to somewhere in your path 14 | $ cp gitbug.opt ~/bin/gitbug 15 | 16 | Usage: 17 | 18 | List of commands: 19 | $ gitbug help 20 | 21 | You need a Git repository: 22 | $ mkdir my_git_repo 23 | $ cd my_git_repo 24 | $ git init 25 | $ echo buggy foo > foo 26 | $ git add foo 27 | $ git commit -m 'buggy foo' 28 | 29 | Then you should initialize the bug tracker: 30 | $ gitbug init 31 | 32 | And add a bug: 33 | $ gitbug add This is my first bug 34 | 35 | Maybe look at it and edit it: 36 | $ gitbug 37 | -- Open bugs 38 | 444468c69994_This_is_my_first_bug 2009-02-16 15:39:18+0200 39 | 40 | $ gitbug show .*first 41 | $ gitbug edit .*first 42 | 43 | Gitbug treats the pattern as a regexp prefixed by `^', so `.*first' 44 | means `^.*first'. Hence you can use the prefix of the hexadecimal part 45 | without the `.*', e.g. `gitbug show 4444`. 46 | 47 | You should fix the bug: 48 | $ echo my great fix >> foo 49 | 50 | And then tell Gitbug what you did: 51 | $ git commit -a -m 'foo: fixed bug, FIX[.*first]' 52 | or 53 | $ git commit -a -m 'foo: fixed bug' 54 | $ gitbug close .*first 55 | 56 | That fix wasn't a fix at all, let us reopen the bug: 57 | $ gitbug reopen .*first 58 | 59 | Make a second bug: 60 | $ gitbug add Bug number two 61 | 62 | Oh, it is a duplicate of the first bug: 63 | $ gitbug merge .*first .*two 64 | 65 | Listing bugs is most useful: 66 | $ gitbug 67 | $ gitbug open 68 | $ gitbug closed 69 | $ gitbug all 70 | 71 | You can see your bug history in git's log: 72 | $ git log 73 | 74 | 75 | License: 76 | 77 | X11 / MIT License 78 | Copyright (C) 2008 Ilmari Heikkinen 79 | Mauricio Fernandez 80 | 81 | 82 | Webpage: 83 | 84 | http://github.com/kig/gitbug/tree/master 85 | 86 | -------------------------------------------------------------------------------- /src/gitbug.ml: -------------------------------------------------------------------------------- 1 | (* 2 | gitbug.ml: In-repo bug tracker for Git. 3 | 4 | Copyright (C) 2008 Ilmari Heikkinen 5 | Mauricio Fernandez 6 | 7 | Permission is hereby granted, free of charge, to any person 8 | obtaining a copy of this software and associated documentation 9 | files (the "Software"), to deal in the Software without 10 | restriction, including without limitation the rights to use, 11 | copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | copies of the Software, and to permit persons to whom the 13 | Software is furnished to do so, subject to the following 14 | conditions: 15 | 16 | The above copyright notice and this permission notice shall be 17 | included in all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 20 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 21 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 22 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 23 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 24 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 25 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 26 | OTHER DEALINGS IN THE SOFTWARE. 27 | *) 28 | 29 | open Prelude 30 | 31 | exception Ambiguous_bug_id of string * string 32 | 33 | let editor () = maybeNF "/bin/vi" Sys.getenv "EDITOR" 34 | let editorCmd () = editor () |> strip |> xsplit "\\s+" 35 | let editFile filename = command (editorCmd () @ [filename]) 36 | 37 | let pager () = maybeNF "/usr/bin/less" Sys.getenv "PAGER" 38 | let pagerCmd () = pager () |> strip |> xsplit "\\s+" 39 | let viewFile filename = command (pagerCmd () @ [filename]) 40 | 41 | let get_homedir user = (Unix.getpwnam user).Unix.pw_dir 42 | let get_realname user = (Unix.getpwnam user).Unix.pw_gecos |> split "," |> first 43 | 44 | let get_user () = (Unix.getpwuid (Unix.getuid ())).Unix.pw_name 45 | 46 | let share_dirs () = [ 47 | get_homedir (get_user ()) ^/ ".gitbug"; 48 | "/usr/share/gitbug"; 49 | "/usr/local/share/gitbug"; 50 | ] 51 | 52 | let default_templates = [ 53 | "add", "-- opened by %USER% on %TIMESTAMP%\n\nProblem description:\n\nHow to reproduce:\n\nProposed solution:\n"; 54 | "edit", "\n-- edited by %USER% on %TIMESTAMP%\n\n"; 55 | "close", "\n-- closed by %USER% on %TIMESTAMP%\n\nFIXED\nWONTFIX\nNOTABUG\nDUPLICATE\n\n"; 56 | "reopen", "\n-- reopened by %USER% on %TIMESTAMP%\n\n"; 57 | "merge", "\n-- merged with %NAME% by %USER% on %TIMESTAMP%\n\n"; 58 | "autoclose", "\n-- closed by %USER% on %TIMESTAMP%\n\nFIXED\n\n"; 59 | ] 60 | 61 | let init_templates () = 62 | maybeNF 63 | default_templates 64 | begin fun dirs -> 65 | let dir = find (fun d -> fileExists (d ^/ "templates")) dirs in 66 | let dir = dir ^/ "templates" in 67 | ls dir |> map (fun fn -> fn, readFile (dir ^/ fn)) 68 | end 69 | (share_dirs ()) 70 | 71 | let name_and_email () = 72 | let email = maybe "" (quote " <" ">") (optNF Sys.getenv "EMAIL") in 73 | let user = get_user () in 74 | let name = maybeE user get_realname user in 75 | name ^ email 76 | 77 | let printfnl msg = printf (msg ^^ "\n") 78 | 79 | let string_of_status = function 80 | `Open -> "OPEN" 81 | | `Close -> "CLOSED" 82 | 83 | module Ticket = 84 | struct 85 | module SM = Map.Make(struct type t = string let compare = String.compare end) 86 | type t = { headers : string SM.t; last_modified : float; body : string list } 87 | 88 | let strip_blank_lines = dropWhile (xmatch "^\\s*$") 89 | 90 | let make name status body = 91 | let now = timeNow () in 92 | let hs = foldl (fun m (k, v) -> SM.add k v m) SM.empty 93 | [ 94 | "status", string_of_status status; 95 | "author", name_and_email (); 96 | "date", showTime @@ now; 97 | "title", name; 98 | "last modified", showTime @@ now; 99 | "reported by", ""; 100 | "assigned to", ""; 101 | ] 102 | in { headers = hs; last_modified = now; body = strip_blank_lines body; } 103 | 104 | let last_modified t = t.last_modified 105 | 106 | let date_of_string s = Netdate.since_epoch (Netdate.parse s) 107 | 108 | let comp_last_modified fname headers body = 109 | try 110 | date_of_string (SM.find "last modified" headers) 111 | with _ -> 112 | match concatMap (rexscan_nth (rex "^--.* on (.*)$") 1) body with 113 | [] -> mtime fname 114 | | l -> 115 | let rec loop t = function 116 | [] -> (match t with None -> mtime fname | Some t -> t) 117 | | s :: tl -> 118 | let t' = try Some (date_of_string s) with _ -> None in 119 | match t, t' with 120 | None, None -> loop None tl 121 | | Some t, None | None, Some t -> loop (Some t) tl 122 | | Some t, Some t' -> loop (Some (max t t')) tl 123 | in loop None l 124 | 125 | let from_file fname = 126 | let headers, body = span (xmatch "^[^:]*:") @@ readLines fname in 127 | let m = foldl (fun m l -> match split ~n:2 ":" l with 128 | [k; v] -> SM.add k (strip v) m 129 | | _ -> m) 130 | SM.empty headers 131 | in { headers = m; 132 | last_modified = comp_last_modified fname m body; 133 | body = strip_blank_lines body } 134 | 135 | let set_header k v t = { t with headers = SM.add k (strip v) t.headers } 136 | 137 | let set_last_modified v t = 138 | { t with last_modified = v; 139 | headers = SM.add "last modified" (showTime v) t.headers; 140 | } 141 | 142 | let title t = maybeNF "" (SM.find "title") t.headers 143 | 144 | let to_string t = 145 | join "\n" @@ 146 | concat [SM.fold (fun k v l -> (k ^ ": " ^ v) :: l) t.headers []; [""]; t.body] 147 | 148 | let string name status body = to_string @@ make name status [body] 149 | end 150 | 151 | let make_dir dir = mkdir_p dir; dir 152 | let make_file_dir f = ignore @@ make_dir @@ dirname f; f 153 | 154 | let base_bug_dir () = 155 | let inode d = (Unix.stat d).Unix.st_ino in 156 | let is_root d = inode d = inode "/" in 157 | let rec loop base = 158 | let dir = base ^/ "bugs" in 159 | if fileExists dir && isDir dir then dir 160 | else if not (is_root base) then loop (base ^/ "..") 161 | else failwith "Couldn't find \"bugs\" base directory." 162 | in loop "." 163 | 164 | let git_dir () = 165 | let inode d = (Unix.stat d).Unix.st_ino in 166 | let is_root d = inode d = inode "/" in 167 | let rec loop base = 168 | let dir = base ^/ ".git" in 169 | if fileExists dir && isDir dir then dir 170 | else if not (is_root base) then loop (base ^/ "..") 171 | else failwith "Couldn't find \".git\" base directory." 172 | in loop "." 173 | 174 | let all_bugs_dir () = make_dir (base_bug_dir () ^/ "all") 175 | let template_dir () = make_dir (base_bug_dir () ^/ "templates") 176 | 177 | let dir_of_status = function 178 | `Open -> base_bug_dir () ^/ "open" 179 | | `Close -> base_bug_dir () ^/ "done" 180 | 181 | let new_normalized_name = xreplaceMulti ["[^a-zA-Z0-9\\s]", ""; "\\s+", "_"] 182 | 183 | let new_id () = 184 | let t = timeNow () in 185 | let s = int t in 186 | let fs = int ((t -. floor t) *. 65536.) in 187 | sprintf "%08x%04x" s fs |> srev 188 | 189 | 190 | let readGit cmd args = readCmd ("git"::cmd::args) 191 | let git cmd args = flush stdout; command ("git"::cmd::args) 192 | 193 | let git_do f x = git "reset" ["--mixed"]; f x 194 | 195 | let git_add fn = git "add" [fn] 196 | let git_commit msg = git "commit" ["-m"; msg] 197 | let git_mv src dst = git "mv" [src; dst] 198 | let git_rm fn = git "rm" [fn] 199 | 200 | let git_edit filename = 201 | editFile filename; 202 | git_add filename 203 | 204 | let add_symlink status file = 205 | let base = basename file in 206 | let dst = dir_of_status status ^/ base in 207 | if fileExists dst then rm dst; 208 | ln_s (".." ^/ "all" ^/ base) @@ make_file_dir dst; 209 | git_add dst 210 | 211 | let remove_symlink status file = 212 | let fn = dir_of_status status ^/ basename file in 213 | if fileExists fn then try git_rm fn with _ -> () (* git rm writes stuff to shell *) 214 | 215 | let template tmpl name = 216 | let template_file = (template_dir () ^/ tmpl) in 217 | let tdata = if fileExists template_file then readFile template_file else "" in 218 | tdata |> sreplaceMulti [ 219 | "%USER%", name_and_email (); 220 | "%TIMESTAMP%", showTime (timeNow()); 221 | "%NAME%", name; 222 | ] 223 | 224 | 225 | let file_with_id dir id = 226 | try ls dir |> find (fun f -> f = id) 227 | with Sys_error _ -> raise Not_found 228 | 229 | let new_bug_file name = 230 | let id = new_id () in 231 | (id, all_bugs_dir () ^/ (id ^ "_" ^ new_normalized_name name)) 232 | 233 | let bug_file ?(dir = all_bugs_dir ()) id = 234 | let f = file_with_id dir id in 235 | (dir ^/ f, f) 236 | 237 | let bug_name = Ticket.title @. Ticket.from_file @. fst @. bug_file 238 | 239 | let writeFile file = writeFile @@ make_file_dir file 240 | let appendFile file = appendFile @@ make_file_dir file 241 | 242 | let append_to_file status file text = 243 | let module T = Ticket in 244 | writeFile file @@ 245 | (T.to_string @@ 246 | T.set_last_modified (timeNow ()) @@ 247 | T.set_header "status" (string_of_status status) @@ T.from_file file) ^ 248 | text 249 | 250 | let open_bug fn = 251 | add_symlink `Open fn; 252 | remove_symlink `Close fn 253 | 254 | let close_bug fn = 255 | add_symlink `Close fn; 256 | remove_symlink `Open fn 257 | 258 | let git_bug_add = git_do (fun name -> 259 | let (id, bug) = new_bug_file name in 260 | writeFile bug (Ticket.string name `Open @@ template "add" name); 261 | git_edit bug; 262 | open_bug bug; 263 | git_commit (sprintf "BUG added: [%s] %s" id name)) 264 | 265 | let digest_of_id s = 266 | let s = first (split "_" s) in 267 | String.sub s 0 (min 7 (String.length s)) 268 | 269 | let git_bug_autoclose = git_do (fun bugs -> 270 | bugs |> iter begin fun id -> 271 | try 272 | print_endline id; 273 | let bug, id = bug_file ~dir:(dir_of_status `Open) id in 274 | let name = bug_name id in 275 | let base = basename bug in 276 | append_to_file `Close bug @@ template "autoclose" name; 277 | git_add bug; 278 | close_bug bug; 279 | git "commit" [ 280 | "--quiet"; 281 | "-m"; (sprintf "BUG closed: [%s] %s" (digest_of_id id) name); 282 | bug; 283 | all_bugs_dir () ^/ base; 284 | dir_of_status `Close ^/ base; 285 | dir_of_status `Open ^/ base; 286 | ] 287 | with _ -> () 288 | end) 289 | 290 | let git_bug_close = git_do (fun id -> 291 | let bug, id = bug_file id in 292 | let name = bug_name id in 293 | append_to_file `Close bug @@ template "close" name; 294 | git_edit bug; 295 | close_bug bug; 296 | git_commit (sprintf "BUG closed: [%s] %s" (digest_of_id id) name)) 297 | 298 | let git_bug_reopen = git_do (fun id -> 299 | let bug, id = bug_file id in 300 | let name = bug_name id in 301 | append_to_file `Open bug @@ template "reopen" name; 302 | git_edit bug; 303 | open_bug bug; 304 | git_commit (sprintf "BUG reopened: [%s] %s" (digest_of_id id) name)) 305 | 306 | let git_bug_edit = git_do (fun id -> 307 | let bug, id = bug_file id in 308 | let name = bug_name id in 309 | appendFile bug (template "edit" name); 310 | git_edit bug; 311 | git_commit (sprintf "BUG edited: [%s] %s" (digest_of_id id) name)) 312 | 313 | let git_bug_merge src dst = git_do (fun () -> 314 | let sfn, src = bug_file src in 315 | let dfn, dst = bug_file dst in 316 | appendFile dfn (template "merge" (bug_name src) ^ readFile sfn); 317 | remove_symlink `Open sfn; 318 | git_edit dfn; 319 | git_commit (sprintf "BUG merged: [%s] -> [%s]" (digest_of_id src) (digest_of_id dst))) () 320 | 321 | let get_bug_list status = 322 | try 323 | let dir = dir_of_status status in 324 | ls dir 325 | |> filter (fun n -> isFile (dir ^/ n)) 326 | |> sortBy (fun n -> Ticket.last_modified (Ticket.from_file (dir ^/ n))) 327 | with Sys_error _ -> [] 328 | 329 | let get_bug_name = function 330 | | [] -> printf "Enter bug name: %!"; read_line () 331 | | args -> join " " args 332 | 333 | let find_bug_id s = 334 | let find_bug re l = match List.filter (fun b -> rexmatch re b) l with 335 | | [] -> raise Not_found 336 | | [x] -> x 337 | | ids -> raise (Ambiguous_bug_id (s, join ", " ids)) in 338 | let re = rex ("^"^s) in 339 | try find_bug re (get_bug_list `Open) 340 | with Not_found -> find_bug re (get_bug_list `Close) 341 | 342 | let get_bug_id = function 343 | | [id] -> find_bug_id id 344 | | _ -> printf "Enter bug ID: %!"; find_bug_id (read_line ()) 345 | 346 | let show_bug dir name = 347 | let file = dir ^/ name in 348 | let ticket = Ticket.from_file file in 349 | let time = showTime (Ticket.last_modified ticket) in 350 | let title = Ticket.title ticket in 351 | sprintf "%-8s %-41s %s" (xfind "^[^_]{0,8}" name) 352 | (String.sub title 0 (min 41 @@ slen title)) time 353 | 354 | let print_bug = puts @.. show_bug 355 | 356 | let add args = 357 | let name = get_bug_name args in 358 | git_bug_add name; 359 | printfnl "Added bug: %s" name 360 | 361 | let do_with_bug_id f msg args = 362 | let id = get_bug_id args in 363 | f id; 364 | printfnl msg id 365 | 366 | let autoclose args = 367 | let last_commit = readGit "log" ["-1"] in 368 | let bugs = if smatch " BUG closed:" last_commit then [] else (* prevent loop *) 369 | last_commit 370 | |> scan_nth "\\bFIX[EDS]*:?\\s*\\[([^\\]]+)\\]" 1 371 | |> concatMap (xsplit "[ ,\n]+") in 372 | match bugs with 373 | | [] -> () 374 | | bugs -> 375 | let bugs = map find_bug_id bugs in 376 | git_bug_autoclose bugs; 377 | puts (sprintf "Autoclosed bug(s): %s" (bugs |> join ", ")) 378 | 379 | let close = do_with_bug_id git_bug_close "Closed bug: %s." 380 | let reopen = do_with_bug_id git_bug_reopen "Reopened bug: %s." 381 | let edit = do_with_bug_id git_bug_edit "Edited bug: %s." 382 | 383 | let list args = 384 | let status, dir_name = match args with 385 | | [] | "open"::_ -> `Open, "Open" 386 | | "closed"::_ -> `Close, "Closed" 387 | | x::_ -> invalid_arg (sprintf "Unknown bug category: %S" x) in 388 | printfnl "-- %s bugs" dir_name; 389 | try get_bug_list status |> iter (print_bug (dir_of_status status)) 390 | with Sys_error _ -> () 391 | 392 | let merge args = 393 | let dst, src = match args with 394 | | s::d::[] -> find_bug_id s, find_bug_id d 395 | | _ -> invalid_arg "merge src dst: wrong amount of args" in 396 | git_bug_merge src dst; 397 | printfnl "Merged bug %s into %s" src dst 398 | 399 | let show args = 400 | let id = get_bug_id args in 401 | viewFile (fst @@ bug_file id) 402 | 403 | let use_autoclose _ = 404 | let edited pc = 405 | let lines = readLines pc in 406 | match lines with 407 | | "#!/bin/sh"::t -> any (not @. xmatch "^\\s*([:#].*|\\s*)$") t 408 | | _ -> true in 409 | let post_commit = git_dir () ^/ "hooks" ^/ "post-commit" in 410 | if fileExists post_commit && edited post_commit 411 | then begin 412 | puts ".git/hooks/post-commit has been edited"; 413 | puts "Please add the autoclose hook manually by calling:"; 414 | puts (sprintf " %s autoclose;" Sys.argv.(0)); 415 | puts "at the end of your post-commit hook." 416 | end else begin 417 | if not (fileExists post_commit) then writeFile post_commit "#!/bin/sh\n"; 418 | appendFile post_commit (sprintf "\n%s autoclose;\n" Sys.argv.(0)); 419 | chmod 0o755 post_commit 420 | end 421 | 422 | let init _ = 423 | use_autoclose []; 424 | mkdir "bugs"; 425 | iter mkdir_p [ 426 | dir_of_status `Open; 427 | dir_of_status `Close; 428 | all_bugs_dir (); 429 | template_dir (); 430 | ]; 431 | iter (fun (fn, s) -> writeFile ("bugs/templates" ^/ fn) s) (init_templates ()); 432 | git_add "bugs"; 433 | git_commit "Initialized bug tracker"; 434 | puts "Initialized the bugs directory." 435 | 436 | let handle_cmd cmd = 437 | let show_help () = 438 | 439 | printfnl "usage: %s CMD [OPTIONS]" (basename Sys.argv.(0)); 440 | printfnl "\nCommands:"; 441 | printfnl "\n Initialize bug tracker:\n init"; 442 | printfnl "\n Manage bugs:\n add close edit merge reopen show"; 443 | printfnl "\n List bugs:\n list all closed open"; 444 | printfnl "\n Close bugs with \"FIX[bug_number]\" in commit message:\n autoclose"; 445 | printfnl "\n Add post-commit hook for autoclose:\n use_autoclose"; 446 | printfnl " init does this for you already, you only need this if you"; 447 | printfnl " haven't done init: i.e. if you're using someone else's repo.\n"; 448 | exit 0 in 449 | let f = match cmd with 450 | | "add" -> add 451 | | "autoclose" -> autoclose 452 | | "use_autoclose" -> use_autoclose 453 | | "close" -> close 454 | | "edit" -> edit 455 | | "init" -> init 456 | | "list" -> list 457 | | "all" -> (fun _ -> list ["open"]; list ["closed"]) 458 | | "open" -> (fun _ -> list ["open"]) 459 | | "closed" -> (fun _ -> list ["closed"]) 460 | | "merge" -> merge 461 | | "reopen" -> reopen 462 | | "show" -> show 463 | | "help" -> show_help () 464 | | s -> show_help () 465 | in f @@ slice 2 (-1) (Array.to_list Sys.argv) 466 | 467 | let () = 468 | let cmd_s = if alen Sys.argv < 2 then "list" else Sys.argv.(1) in 469 | handle_cmd cmd_s 470 | 471 | -------------------------------------------------------------------------------- /src/prelude.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Prelude.ml: OCaml utility functions 3 | 4 | Copyright (C) 2008 Ilmari Heikkinen 5 | 6 | Permission is hereby granted, free of charge, to any person 7 | obtaining a copy of this software and associated documentation 8 | files (the "Software"), to deal in the Software without 9 | restriction, including without limitation the rights to use, 10 | copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the 12 | Software is furnished to do so, subject to the following 13 | conditions: 14 | 15 | The above copyright notice and this permission notice shall be 16 | included in all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 19 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 20 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 21 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 22 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 23 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 24 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 25 | OTHER DEALINGS IN THE SOFTWARE. 26 | *) 27 | 28 | (* 29 | #use "topfind";; 30 | #require "pcre";; 31 | #require "unix";; 32 | #require "netstring";; 33 | #use "prelude.ml";; 34 | interact @@ uppercase @. join "-" @. words;; 35 | *) 36 | 37 | include Printf 38 | include List 39 | 40 | 41 | (* Function combinators *) 42 | 43 | let (@@) f x = f x 44 | (**T 45 | map (multiply 2) @@ reverse (1--3) = [6; 4; 2] 46 | int @@ ceil @@ sqrt @@ float 144 = 12 47 | **) 48 | let (@.) f g x = f (g x) 49 | (**T 50 | map (join "-" @. words) ["a b"; "b c"] = ["a-b"; "b-c"] 51 | (int @. ceil @. sqrt @. float) 144 = 12 52 | **) 53 | let (@..) f g x y = f (g x y) 54 | (**T 55 | (reverse @.. zip) (1--3) (4--6) = [(3, 6); (2, 5); (1, 4)] 56 | **) 57 | let (@...) f g x y z = f (g x y z) 58 | (**T 59 | (rev @... unfoldr) (lessOrEqualTo 3) (fupler succ) 1 = [1; 2; 3] 60 | **) 61 | let (@....) f g w x y z = f (g w x y z) 62 | (**T 63 | (rev @.... unfoldrFilter) (lte 7) even (fupler succ) 1 = [2; 4; 6] 64 | **) 65 | let (|>) x f = f x 66 | (**T 67 | (1--3) |> reverse |> map (multiply 2) = [6; 4; 2] 68 | 144 |> float |> sqrt = 12.0 69 | **) 70 | let (|>.) f g x = g (f x) 71 | (**T 72 | map (words |>. join "-") ["a b"; "b c"] = ["a-b"; "b-c"] 73 | map (float |>. sqrt |>. ceil |>. int) [1; 4; 9; 15] = [1; 2; 3; 4] 74 | **) 75 | let uncurry f (a, b) = f a b 76 | (**T 77 | uncurry (+) (1,2) = 3 78 | uncurry (@) @@ unzip @@ map (fun x -> (x, x+3)) (1--3) = (1--6) 79 | **) 80 | let curry f a b = f (a, b) 81 | (**T 82 | curry reverseTuple 1 2 = (2,1) 83 | **) 84 | let flip f a b = f b a 85 | (**T 86 | (flip map (65--68)) chr = ['A'; 'B'; 'C'; 'D'] 87 | **) 88 | let dup f x = f x x 89 | (**T 90 | map (dup multiply) (1--3) = [1; 4; 9] 91 | **) 92 | let id x = x 93 | (**T 94 | maybe 0 id (Some 1) = 1 95 | **) 96 | let const x y = x 97 | (**T 98 | map (const 1) ['a'; 'b'; 'c'] = [1; 1; 1] 99 | **) 100 | 101 | 102 | (* Ifs *) 103 | 104 | let ifP p x y n = if p n then x else y 105 | let ifB b x y = if b then x else y 106 | 107 | 108 | (* Tuple operations *) 109 | 110 | let tuple a b = (a,b) 111 | let tuple3 a b c = (a,b,c) 112 | let reverseTuple (a,b) = (b,a) 113 | let trev = reverseTuple 114 | let fuple f g a = (f a, g a) 115 | let fuplel f a = (f a, a) 116 | let fupler f a = (a, f a) 117 | 118 | 119 | (* Option combinators *) 120 | 121 | let some x = Some x 122 | let none x = None 123 | 124 | let opt_or o y = match o with Some x -> x | None -> y 125 | (**T 126 | opt_or None 0 = 0 127 | opt_or (Some 10) 0 = 10 128 | **) 129 | let (|?) = opt_or 130 | let optOr y o = match o with Some x -> x | None -> y 131 | (**T 132 | optOr 0 None = 0 133 | optOr 0 (Some 10) = 10 134 | **) 135 | 136 | let maybe v f o = match o with Some x -> f x | None -> v 137 | (**T 138 | maybe 0 parseInt (Some "10") = 10 139 | maybe 0 parseInt None = 0 140 | **) 141 | let unmaybe b f v = if b = v then None else Some (f v) 142 | (**T 143 | unmaybe 0 showInt 10 = Some "10" 144 | unmaybe 0 showInt 0 = None 145 | **) 146 | let optIf p f v = if p v then Some (f v) else None 147 | (**T 148 | optIf (greaterThan 0) (add 5) 0 = None 149 | optIf (greaterThan 0) (add 5) 1 = Some 6 150 | unfoldrOpt (optIf (greaterThan 0) (fun x -> (x, x-1))) 5 = [1;2;3;4;5] 151 | **) 152 | 153 | 154 | (* Exception handling combinators *) 155 | 156 | let maybeE v f o = try f o with _ -> v 157 | (**T 158 | maybeE 0 last [] = 0 159 | maybeE 0 last [1] = 1 160 | **) 161 | let maybeEx ex v f o = try f o with e when ex = e -> v 162 | (**T 163 | maybeEx Not_found 0 last [] = 0 164 | maybeEx Not_found 0 last [1] = 1 165 | (try maybeEx Not_found 0 raise Exit with Exit -> 1) = 1 166 | **) 167 | let maybeExl exl v f o = 168 | try f o with x -> if exists ((=) x) exl then v else raise x 169 | (**T 170 | maybeExl [Not_found] 0 last [] = 0 171 | maybeExl [Not_found] 0 last [1] = 1 172 | **) 173 | let maybeEOF v f o = maybeEx End_of_file v f o 174 | (* 175 | unfoldlOpt (maybeEOF None (fun ic -> Some (readInt ic, ic)) ic) stdin;; 176 | *) 177 | let maybeNF v f o = maybeEx Not_found v f o 178 | (**T 179 | maybeNF 0 last [] = 0 180 | maybeNF 0 last [1;2;3] = 3 181 | **) 182 | 183 | 184 | (* Exceptions to options *) 185 | 186 | let optE f o = maybeE None (some @. f) o 187 | let optEx ex f o = maybeEx ex None (some @. f) o 188 | let optExl exl f o = maybeExl exl None (some @. f) o 189 | let optEOF f o = maybeEOF None (some @. f) o 190 | let optNF f o = maybeEx Not_found None (some @. f) o 191 | (**T 192 | optNF last [] = None 193 | optNF last [1;2;3] = Some 3 194 | **) 195 | 196 | let rec loop f x = f x; loop f x 197 | (* 198 | loop (print_endline @. input_line) stdin;; 199 | *) 200 | 201 | 202 | (* Comparisons *) 203 | 204 | let lessThan x y = (<) y x 205 | (**T 206 | filter (lessThan 3) (1--10) = [1; 2] 207 | **) 208 | let lessOrEqualTo x y = (<=) y x 209 | (**T 210 | filter (lessOrEqualTo 3) (1--10) = [1; 2; 3] 211 | **) 212 | let greaterThan x y = (>) y x 213 | (**T 214 | filter (greaterThan 7) (1--10) = [8; 9; 10] 215 | **) 216 | let greaterOrEqualTo x y = (>=) y x 217 | (**T 218 | filter (greaterOrEqualTo 7) (1--10) = [7; 8; 9; 10] 219 | **) 220 | 221 | let eq = (=) 222 | let neq = (<>) 223 | let equals = (=) 224 | (**T 225 | filter (modulo 2 |>. equals 0) (1--10) = [2; 4; 6; 8; 10] 226 | **) 227 | 228 | let lt = lessThan 229 | let lte = lessOrEqualTo 230 | let gt = greaterThan 231 | let gte = greaterOrEqualTo 232 | 233 | let between a b x = x >= a && x <= b 234 | 235 | 236 | (* Conversions *) 237 | 238 | let array = Array.of_list 239 | let list = Array.to_list 240 | let int = int_of_float 241 | let char = char_of_int 242 | let parseInt = int_of_string 243 | let parseFloat = float_of_string 244 | let showInt = string_of_int 245 | let showFloat f = 246 | Pcre.replace ~rex:(Pcre.regexp "\\.$") ~templ:".0" (string_of_float f) 247 | let charCode = int_of_char 248 | let ord = int_of_char 249 | let chr = char_of_int 250 | 251 | 252 | (* Float operations *) 253 | 254 | let round f = truncate (if f > 0.0 then f +. 0.5 else f -. 0.5) 255 | (**T 256 | round 0.5 = 1 257 | round 0.4 = 0 258 | round (-0.4) = 0 259 | round (-0.5) = -1 260 | **) 261 | let ceiling = ceil 262 | let quot f i = (truncate f) / i 263 | (**T 264 | quot 5.0 2 = 2 265 | **) 266 | let recip f = 1. /. f 267 | let signumf f = if f > 0. then 1. else if f < 0. then (-.1.) else 0. 268 | let logBase base f = log f /. log base 269 | let root rt f = f ** (recip rt) 270 | let absf f = (signumf f) *. f 271 | let pi = 4. *. atan 1. 272 | let addf = (+.) 273 | let subtractf a b = b -. a 274 | let multiplyf = ( *. ) 275 | let dividef a b = b /. a 276 | let negatef v = (-.v) 277 | let average2f a b = (a +. b) /. 2.0 278 | 279 | 280 | (* Integer operations *) 281 | 282 | let average2 a b = (a + b) / 2 283 | let quot_rem a b = 284 | let q = a / b in 285 | (q, a - (q*b)) 286 | let rem a b = a mod b 287 | let even x = x mod 2 == 0 288 | let odd x = x mod 2 == 1 289 | let signum i = if i > 0 then 1 else if i < 0 then (-1) else 0 290 | let succ x = x + 1 291 | let pred x = x - 1 292 | let add = (+) 293 | let subtract a b = b - a 294 | (**T 295 | map (subtract 10) (11--13) = [1; 2; 3] 296 | **) 297 | let multiply = ( * ) 298 | let divide a b = b / a 299 | (**T 300 | map (divide 10) [10; 20; 30] = [1; 2; 3] 301 | **) 302 | let modulo a b = b mod a 303 | (**T 304 | filter (modulo 2 |>. equals 0) (1--10) = [2; 4; 6; 8; 10] 305 | **) 306 | let negate v = (-v) 307 | 308 | let rec gcd x y = match (abs x), (abs y) with 309 | | 0,0 -> invalid_arg "Prelude.gcd: gcd 0 0 is undefined" 310 | | x,0 -> x 311 | | x,y -> gcd y (rem x y) 312 | 313 | let lcm x y = match x, y with 314 | | _,0 | 0,_ -> 0 315 | | x,y -> abs ((x / (gcd x y)) * y) 316 | 317 | 318 | (* List operations *) 319 | 320 | let reverse = rev 321 | 322 | let nth i l = List.nth l i 323 | let ($$) = List.nth 324 | 325 | let cons x xs = x::xs 326 | let head = function [] -> raise Not_found | (h::_) -> h 327 | let tail = function [] -> raise Not_found | (_::t) -> t 328 | let pop l = 329 | let rec aux l res = 330 | match l with 331 | | [] -> raise Not_found 332 | | (h::[]) -> (rev res, h) 333 | | (h::t) -> aux t (h :: res) in 334 | aux l [] 335 | (**T 336 | pop [1;2;3] = ([1;2], 3) 337 | **) 338 | let popped l = fst (pop l) 339 | (**T 340 | popped [1; 2; 3] = [1; 2] 341 | **) 342 | let last l = snd (pop l) 343 | (**T 344 | last [1; 2; 3] = 3 345 | **) 346 | let first = head 347 | 348 | let map f l = rev (rev_map f l) 349 | 350 | let rec assocBy f l = 351 | match l with 352 | | [] -> raise Not_found 353 | | (k,v)::t when f k -> v 354 | | _::t -> assocBy f t 355 | 356 | let lookup e l = optNF (assoc e) l 357 | let lookupBy f e l = optNF (assocBy f e) l 358 | 359 | let len = length 360 | 361 | let all = for_all 362 | let any = exists 363 | 364 | let allEqual l = match l with 365 | | [] -> true 366 | | (h::t) -> all ((=) h) t 367 | 368 | let includes x = exists (fun y -> x = y) 369 | let has = includes 370 | let elem = includes 371 | let notElem x lst = not @@ elem x lst 372 | 373 | let indexOf x lst = 374 | let rec aux x c l = match l with 375 | | [] -> raise Not_found 376 | | (h::t) when x = h -> c 377 | | (h::t) -> aux x (c+1) t in 378 | aux x 0 lst 379 | (**T 380 | indexOf 'a' (explode "foobar") = 4 381 | **) 382 | let findIndex p lst = 383 | let rec aux p c l = match l with 384 | | [] -> raise Not_found 385 | | (h::t) -> if p h then c else aux p (c+1) t in 386 | aux p 0 lst 387 | (**T 388 | findIndex (gt 4) (0--9) = 5 389 | **) 390 | let findWithIndex p lst = 391 | let rec aux p c l = match l with 392 | | [] -> raise Not_found 393 | | (h::t) -> if p h then (h,c) else aux p (c+1) t in 394 | aux p 0 lst 395 | (**T 396 | findWithIndex (gt 4) (2--9) = (5,3) 397 | **) 398 | let rec recurseOpt f i = match f i with None -> i | Some x -> recurseOpt f x 399 | let rec recurseWhile p f i = if p i then recurseWhile p f (f i) else i 400 | let rec recurseUntil p f i = if p i then i else recurseUntil p f (f i) 401 | let rec recurseTo n f i = if n = i then i else recurseTo n f (f i) 402 | let rec recurseN f n i = if n <= 0 then i else recurseN f (n-1) (f i) 403 | 404 | let null = function [] -> true | _ -> false 405 | 406 | let concatMap f l = concat (map f l) 407 | (**T 408 | concatMap ((--) 1) [1;2;3] = [1; 1; 2; 1; 2; 3] 409 | **) 410 | 411 | let pick indices l = map (flip nth l) indices 412 | (**T 413 | pick [2; 3] (explode "foobar") = ['o'; 'b'] 414 | **) 415 | let pickWith funcs l = map ((|>) l) funcs 416 | (**T 417 | pickWith [first; last] (explode "foobar") = ['f'; 'r'] 418 | **) 419 | let pickArray indices l = map (Array.get l) indices 420 | let pickArrayWith funcs l = map ((|>) l) funcs 421 | 422 | let span f lst = 423 | let rec aux f res l = match l with 424 | | (h::t) when f h -> aux f (h::res) t 425 | | x -> (rev res, x) in 426 | aux f [] lst 427 | (**T 428 | span id [true; false; false; true] = ([true], [false; false; true]) 429 | span (lessOrEqualTo 5) (1--10) = ([1; 2; 3; 4; 5], [6; 7; 8; 9; 10]) 430 | **) 431 | let break p = span (not @. p) 432 | (**T 433 | break id [false; false; true; false] = ([false; false], [true; false]) 434 | break (greaterThan 5) (1--10) = ([1; 2; 3; 4; 5], [6; 7; 8; 9; 10]) 435 | **) 436 | 437 | let takeWhile f lst = fst @@ span f lst 438 | let take n lst = 439 | let rec aux c res l = match c, l with 440 | | x, (h::t) when x > 0 -> aux (c-1) (h::res) t 441 | | _ -> rev res in 442 | aux n [] lst 443 | 444 | let rec dropWhile f lst = match lst with 445 | | (h::t) when f h -> dropWhile f t 446 | | _ -> lst 447 | let rec drop n lst = match n, lst with 448 | | x, (h::t) when x > 0 -> drop (n-1) t 449 | | _ -> lst 450 | 451 | let rec dropWhile2 f a b = match a,b with 452 | | (x::xs), (y::ys) when f x y -> dropWhile2 f xs ys 453 | | _ -> a,b 454 | let rec drop2 n a b = match n,a,b with 455 | | c, (x::xs), (y::ys) when c > 0 -> drop2 c xs ys 456 | | _ -> a,b 457 | 458 | let splitAt n xs = (take n xs, drop n xs) 459 | (**T 460 | splitAt 3 (explode "foobar") = (['f'; 'o'; 'o'], ['b'; 'a'; 'r']) 461 | **) 462 | 463 | let sub first len lst = 464 | let rec f l fst ln c res = match l with 465 | | [] -> res 466 | | h::t when c >= (fst + ln) -> res 467 | | h::t when c >= fst -> f t fst ln (c+1) (h::res) 468 | | h::t -> f t fst ln (c+1) res in 469 | let first = if first < 0 then length lst + first else first in 470 | List.rev (f lst first len 0 []) 471 | (**T 472 | sub 2 3 (explode "foobar") = ['o'; 'b'; 'a'] 473 | sub (-3) 2 (explode "foobar") = ['b'; 'a'] 474 | **) 475 | let slice first last lst = 476 | let len = if first < 0 || last < 0 then length lst else 0 in 477 | let first = if first < 0 then len + first else first in 478 | let last = if last < 0 then len + last else last in 479 | sub first (last-first+1) lst 480 | (**T 481 | slice 2 3 (explode "foobar") = ['o'; 'b'] 482 | slice (-3) (-1) (explode "foobar") = ['b'; 'a'; 'r'] 483 | **) 484 | 485 | let interlace elem l = 486 | let rec aux l l2 = match l with 487 | | [] -> (match l2 with [] -> [] | (h::t) -> List.rev t) 488 | | (h::t) -> aux t (elem :: h :: l2) in 489 | aux l [] 490 | (**T 491 | interlace 0 [1; 2; 3] = [1; 0; 2; 0; 3] 492 | implode @@ interlace '-' @@ explode "abcde" = "a-b-c-d-e" 493 | **) 494 | 495 | let compact l = map (function Some x -> x | _ -> failwith "compact") 496 | (filter ((!=) None) l) 497 | (**T 498 | compact [None; Some 10; Some 5; None; None; Some 8] = [10; 5; 8] 499 | compact @@ map (optIf (greaterThan 0) id) (-3--3) = [1; 2; 3] 500 | **) 501 | 502 | let squeeze l = 503 | let rec aux x l1 l2 = match l1 with 504 | | [] -> (rev l2) 505 | | (h::t) when h = x -> aux x t l2 506 | | (h::t) -> aux h t (h::l2) 507 | in 508 | match l with [] -> [] | (h::t) -> aux h t [h] 509 | (**T 510 | squeeze [1;2;2;2;3;3;1] = [1; 2; 3; 1] 511 | squeeze @@ sort [1;2;2;2;3;3;1] = [1; 2; 3] 512 | **) 513 | 514 | let sort ?(cmp=compare) l = List.sort cmp l 515 | let sortBy ?(cmp=compare) f l = 516 | map (fupler f) l |> sort ~cmp:(fun (_,a) (_,b) -> cmp a b) |> map fst 517 | let uniq ?cmp l = squeeze (sort ?cmp l) 518 | (**T 519 | uniq [3;1;2;2;2;3;3;1] = [1; 2; 3] 520 | **) 521 | 522 | let reject f l = filter (not @. f) l 523 | (**T 524 | reject (gt 4) (1--5) = (1--4) 525 | **) 526 | 527 | let without x l = filter ((<>) x) l 528 | (**T 529 | without 4 [1; 2; 4; 1; 2; 4] = [1; 2; 1; 2] 530 | **) 531 | 532 | let rec neighbours item items = match items with 533 | | (p::i::n::t) when i == item -> (Some p, Some n) 534 | | (i::n::t) when i == item -> (None, Some n) 535 | | (p::i::[]) when i == item -> (Some p, None) 536 | | (h::t) -> neighbours item t 537 | | [] -> (None, None) 538 | (**T 539 | neighbours 2 (1--10) = (Some 1, Some 3) 540 | neighbours 10 (1--10) = (Some 9, None) 541 | neighbours 1 (1--10) = (None, Some 2) 542 | neighbours 0 (1--10) = (None, None) 543 | neighbours 11 (1--10) = (None, None) 544 | **) 545 | 546 | let neighbourLists item n items = 547 | let rec aux prev lst = 548 | match lst with 549 | | [] -> ([], []) 550 | | (i::[]) when i = item -> (prev, []) 551 | | (i::t) when i = item -> (prev, take n t) 552 | | (h::t) -> aux (take n (h::prev)) t 553 | in 554 | aux [] items 555 | (**T 556 | neighbourLists 5 2 (1--10) = ([4; 3], [6; 7]) 557 | neighbourLists 7 3 (1--10) = ([6; 5; 4], [8; 9; 10]) 558 | neighbourLists 2 5 (1--10) = ([1], [3; 4; 5; 6; 7]) 559 | neighbourLists 9 3 (1--10) = ([8; 7; 6], [10]) 560 | neighbourLists 0 4 (1--10) = ([], []) 561 | **) 562 | 563 | let mapWindow f n l = 564 | let rec aux f wnd lst res = 565 | match lst with 566 | | [] -> rev res 567 | | (h::t) -> 568 | let wnd = tail wnd @ [h] in 569 | aux f wnd t ((f wnd) :: res) in 570 | let wnd, t = splitAt n l in 571 | aux f wnd t [f wnd] 572 | (**T 573 | mapWindow sum 1 (1--4) = (1--4) 574 | mapWindow sum 2 (1--4) = [3; 5; 7] 575 | mapWindow sum 3 (1--4) = [6; 9] 576 | **) 577 | 578 | let foldl = fold_left 579 | (**T 580 | foldl (+) 0 (1--10) = 55 581 | foldl (fun s b -> s ^ (string_of_int b)) "--" (1--3) = "--123" 582 | **) 583 | let foldl1 f l = foldl f (head l) (tail l) 584 | (**T 585 | foldl1 (+) (1--10) = 55 586 | foldl1 (fun s i -> s ^ i) ["foo"; "bar"; "baz"] = "foobarbaz" 587 | **) 588 | 589 | let foldr f s l = fold_right f l s 590 | (**T 591 | foldr (+) 0 (1--10) = 55 592 | foldr (fun a s -> s ^ (string_of_int a)) "--" (1--3) = "--321" 593 | **) 594 | let foldr1 f l = let l,i = pop l in foldr f i l 595 | (**T 596 | foldr1 (+) (1--10) = 55 597 | foldr1 (fun a s -> s ^ a) ["foo"; "bar"; "baz"] = "bazbarfoo" 598 | **) 599 | 600 | let scanl f init lst = rev @@ snd @@ 601 | foldl (fun (s,l) i -> let s' = f s i in (s', s'::l)) (init, [init]) lst 602 | (**T 603 | scanl multiply 1 (2--5) = [1; 2; 6; 24; 120] 604 | **) 605 | let scanl1 f l = scanl f (head l) (tail l) 606 | (**T 607 | scanl1 multiply (1--5) = [1; 2; 6; 24; 120] 608 | **) 609 | 610 | let scanr f init lst = snd @@ 611 | foldr (fun i (s,l) -> let s' = f s i in (s', s'::l)) (init, [init]) lst 612 | (**T 613 | scanr multiply 1 @@ [5;4;3;2] = [120; 24; 6; 2; 1] 614 | **) 615 | let scanr1 f l = let l,i = pop l in scanr f i l 616 | (**T 617 | scanr1 multiply @@ [5;4;3;2;1] = [120; 24; 6; 2; 1] 618 | **) 619 | 620 | let unfoldrOpt f init = 621 | let rec aux f v l = 622 | match f v with 623 | | None -> l 624 | | Some (a, b) -> aux f b (a::l) in 625 | aux f init [] 626 | (**T 627 | unfoldrOpt (fun x -> if x > 3 then None else Some (x, x+1)) 1 = [3; 2; 1] 628 | unfoldrOpt (fun i -> if i > 67 then None else Some (char i, i+1)) 65 = ['C';'B';'A'] 629 | **) 630 | let unfoldlOpt f init = rev (unfoldrOpt f init) 631 | (**T 632 | unfoldlOpt (fun x -> if x > 3 then None else Some (x, x+1)) 1 = [1; 2; 3] 633 | unfoldlOpt (fun i -> if i > 67 then None else Some (char i, i+1)) 65 = ['A';'B';'C'] 634 | **) 635 | 636 | let unfoldr p f init = unfoldrOpt (optIf p f) init 637 | (**T 638 | unfoldr (lessThan 4) (fupler succ) 1 = [3; 2; 1] 639 | unfoldr (lessThan 68) (fuple char succ) 65 = ['C'; 'B'; 'A'] 640 | **) 641 | let unfoldl p f init = rev (unfoldr p f init) 642 | (**T 643 | unfoldl (lessThan 4) (fupler succ) 1 = [1; 2; 3] 644 | unfoldl (lessThan 68) (fuple char succ) 65 = ['A'; 'B'; 'C'] 645 | **) 646 | let unfoldrWhile = unfoldr 647 | let unfoldlWhile = unfoldl 648 | 649 | let unfoldrUntil p f init = unfoldr (not @. p) f init 650 | let unfoldlUntil p f init = unfoldl (not @. p) f init 651 | 652 | let unfoldrFilter p s f init = 653 | let rec aux p f v l = 654 | if not (p v) then l 655 | else let a,b = f v in 656 | aux p f b (if s v then (a::l) else l) in 657 | aux p f init [] 658 | (**T 659 | unfoldrFilter (lt 7) even (fupler succ) 1 = [6; 4; 2] 660 | unfoldrFilter (lt 7) even (fuple (divide 2) succ) 2 = [3; 2; 1] 661 | **) 662 | let unfoldlFilter p s f init = rev @@ unfoldrFilter p s f init 663 | (**T 664 | unfoldlFilter (lt 7) even (fupler succ) 1 = [2; 4; 6] 665 | unfoldlFilter (lt 7) even (fuple (divide 2) succ) 2 = [1; 2; 3] 666 | **) 667 | 668 | let unfoldlN f n i = 669 | unfoldlWhile (snd |>. gt 0) (fun (s,c) -> (f s, (s, pred c))) (i, n) 670 | 671 | let forN f n = for i=0 to (n-1) do f i done 672 | 673 | let generateOpt f init = 674 | unfoldlOpt (fun x -> match f x with Some a -> Some (x,a) | None -> None) init 675 | (**T 676 | generateOpt (fun x -> if x > 3 then None else Some (x+1)) 1 = [1; 2; 3] 677 | **) 678 | let generate p f init = unfoldl p (fupler f) init 679 | (**T 680 | generate (lessOrEqualTo 3) succ 1 = [1; 2; 3] 681 | **) 682 | let generateUntil p f init = generate (not @. p) f init 683 | 684 | let generateOptR f init = 685 | unfoldrOpt (fun x -> match f x with Some a -> Some (x,a) | None -> None) init 686 | (**T 687 | generateOptR (fun x -> if x > 3 then None else Some (x+1)) 1 = [3; 2; 1] 688 | **) 689 | let generateR p f init = unfoldr p (fupler f) init 690 | (**T 691 | generateR (lte 3) succ 1 = [3; 2; 1] 692 | **) 693 | let generateUntilR p f init = generateR (not @. p) f init 694 | 695 | let zipWith f a b = 696 | let rec aux f a b l = match a,b with 697 | | (x::xs), (y::ys) -> aux f xs ys ((f x y)::l) 698 | | _ -> l in 699 | rev @@ aux f a b [] 700 | let zip a b = zipWith tuple a b 701 | let unzip = split 702 | 703 | let rec zipWith3 f a b c = match a,b,c with 704 | | (h1::t1), (h2::t2), (h3::t3) -> (f h1 h2 h3) :: (zipWith3 f t1 t2 t3) 705 | | _ -> [] 706 | let zip3 a b c = zipWith3 tuple3 a b c 707 | let unzip3 l = 708 | foldr (fun (a,b,c) (t1,t2,t3) -> (a::t1, b::t2, c::t3)) ([],[],[]) l 709 | 710 | let iterWithIndex f l = ignore (foldl (fun j i -> f i j; j+1) 0 l) 711 | let each = iter 712 | let eachWithIndex = iterWithIndex 713 | let mapWithIndex f l = 714 | rev (snd (foldl (fun (j,r) i -> (j+1, (f i j)::r)) (0, []) l)) 715 | 716 | let diffSorted a b = 717 | let rec aux a b l = 718 | match b with 719 | | [] -> (rev l) @ a 720 | | (x::xs) -> begin 721 | match a with 722 | | [] -> rev l 723 | | (y::ys) -> 724 | if y = x then aux ys xs l 725 | else if y > x then aux a xs l 726 | else aux ys b (y::l) 727 | end in 728 | aux a b [] 729 | (**T 730 | diffSorted (1--10) (5--15) = [1; 2; 3; 4] 731 | diffSorted (5--15) (1--10) = [11; 12; 13; 14; 15] 732 | diffSorted [3;2;1] [1;0] = [3; 2; 1] 733 | **) 734 | 735 | let diff a b = 736 | let rec aux a b l = 737 | match b with 738 | | [] -> (rev l) @ a 739 | | (x::xs) -> begin 740 | match a with 741 | | [] -> rev l 742 | | ((y,i)::ys) -> 743 | if y = x then aux ys xs l 744 | else if y > x then aux a xs l 745 | else aux ys b ((y,i)::l) 746 | end in 747 | let diffs = 748 | aux (List.sort (fun (y,_) (y',_) -> compare y y') (mapWithIndex tuple a)) 749 | (sort b) [] in 750 | map fst (List.sort (fun (_,i) (_,i') -> compare i i') diffs) 751 | (**T 752 | diff (1--10) (5--15) = [1; 2; 3; 4] 753 | diff (5--15) (1--10) = [11; 12; 13; 14; 15] 754 | diff [3;2;1] [1;0] = [3; 2] 755 | **) 756 | 757 | let product lst = foldl ( * ) 1 lst 758 | let productf lst = foldl ( *. ) 1. lst 759 | let sum lst = foldl (+) 0 lst 760 | let sumf lst = foldl (+.) 0. lst 761 | let average lst = (sum lst) / (length lst) 762 | let averagef lst = (sumf lst) /. (float (length lst)) 763 | 764 | let cycle n l = 765 | let rec aux c lst res = 766 | if c == 0 then res 767 | else match lst with 768 | | [] -> aux c l res 769 | | (h::t) -> aux (c-1) t (h::res) in 770 | match l with 771 | | [] -> invalid_arg "cycle" 772 | | _ -> reverse @@ aux n l [] 773 | (**T 774 | cycle 5 (1--3) = [1; 2; 3; 1; 2] 775 | cycle 3 (1--10) = [1; 2; 3] 776 | **) 777 | 778 | let range s e = 779 | if s <= e 780 | then generateR (greaterOrEqualTo s) pred e 781 | else generateR (lessOrEqualTo s) succ e 782 | (**T 783 | range 1 3 = [1; 2; 3] 784 | range 1 1 = [1] 785 | range 1 0 = [1; 0] 786 | **) 787 | let generateN f n = 788 | let rec aux f n res = 789 | if n < 0 then res 790 | else aux f (n-1) ((f n) :: res) in 791 | aux f (n-1) [] 792 | let init = generateN 793 | (**T 794 | init succ 10 = (1--10) 795 | init pred 10 = ((-1)--8) 796 | **) 797 | let step d s e = 798 | if d == 0 then failwith "Prelude.step: zero step" else 799 | if s == e then [s] else 800 | if s < e 801 | then (if d < 0 then [] else generate (lte e) (add d) s) 802 | else (if d > 0 then [] else generate (gte e) (add d) s) 803 | (**T 804 | step 2 0 5 = [0; 2; 4] 805 | step 2 1 5 = [1; 3; 5] 806 | step (-2) 5 1 = [5; 3; 1] 807 | step (-2) 5 0 = [5; 3; 1] 808 | **) 809 | let (--) = range 810 | (**T 811 | (1--3) = [1; 2; 3] 812 | (1--1) = [1] 813 | (1--0) = [1; 0] 814 | **) 815 | 816 | let replicate n v = init (const v) n 817 | (**T 818 | replicate 5 '-' = ['-'; '-'; '-'; '-'; '-'] 819 | replicate 0 '-' = [] 820 | replicate (-1) '-' = [] 821 | **) 822 | let repeat v n = init (const v) n 823 | (**T 824 | repeat '-' 5 = ['-'; '-'; '-'; '-'; '-'] 825 | repeat '-' 0 = [] 826 | repeat '-' (-1) = [] 827 | **) 828 | let times n l = concat @@ replicate n l 829 | (**T 830 | times 3 [1; 2; 3] = [1; 2; 3; 1; 2; 3; 1; 2; 3] 831 | **) 832 | let (@*) l n = times n l 833 | (**T 834 | [1; 2; 3] @* 3 = [1; 2; 3; 1; 2; 3; 1; 2; 3] 835 | **) 836 | let (^*) s n = String.concat "" (repeat s n) 837 | (**T 838 | "foo" ^* 3 = "foofoofoo" 839 | **) 840 | let (@|) a1 a2 = Array.concat [a1; a2] 841 | (**T 842 | (1--|3) @| (4--|6) = (1--|6) 843 | **) 844 | let (@|*) a n = Array.concat (repeat a n) 845 | (** 846 | (1--|2) @|* 3 = [|1;2;1;2;1;2|] 847 | **) 848 | 849 | let explode s = 850 | unfoldr (greaterOrEqualTo 0) (fun i -> (String.unsafe_get s i, i-1)) 851 | (String.length s - 1) 852 | (**T 853 | explode "foo" = ['f'; 'o'; 'o'] 854 | **) 855 | let implode lst = 856 | fst @@ foldl (fun (s,c) i -> String.unsafe_set s c i; (s, c+1)) 857 | (String.create @@ length lst, 0) lst 858 | (**T 859 | implode @@ explode "foo" = "foo" 860 | **) 861 | 862 | let iterate f n s = scanl (fun s i -> f s) s (2--n) 863 | (**T 864 | iterate succ 10 1 = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10] 865 | iterate pred 4 1 = [1; 0; -1; -2] 866 | **) 867 | let maximum lst = foldl1 max lst 868 | (**T 869 | maximum [1;2;3;0;1;4;3;1] = 4 870 | **) 871 | let maxBy f a b = if (f a) >= (f b) then a else b 872 | let maximumBy f lst = foldl1 (maxBy f) lst 873 | let maximumByWith f lst = maximumBy snd (map (fupler f) lst) 874 | let minimum lst = foldl1 min lst 875 | (**T 876 | minimum [1;2;3;0;1;4;3;1] = 0 877 | **) 878 | let minBy f a b = if (f a) <= (f b) then a else b 879 | let minimumBy f lst = foldl1 (minBy f) lst 880 | let minimumByWith f lst = minimumBy snd (map (fupler f) lst) 881 | 882 | let groupsOf n l = if n <= 1 then [l] 883 | else unfoldlUntil null (splitAt n) l 884 | (**T 885 | groupsOf 3 (1--10) = [[1; 2; 3]; [4; 5; 6]; [7; 8; 9]; [10]] 886 | **) 887 | let splitInto n l = if n <= 1 then [l] 888 | else groupsOf (int (ceil (float (len l) /. float n))) l 889 | (**T 890 | splitInto 4 (1--10) = [[1; 2; 3]; [4; 5; 6]; [7; 8; 9]; [10]] 891 | **) 892 | let groupBy p l = 893 | let rec aux p v l rl res = match l with 894 | | [] -> (rev rl) :: res 895 | | (h::t) when p v h -> aux p v t (h::rl) res 896 | | (h::t) -> aux p h t [h] ((rev rl) :: res) in 897 | match l with [] -> [] 898 | | (h::t) -> rev (aux p h t [h] []) 899 | (**T 900 | groupBy (fun x y -> x*x = y*y) [-1; 1; -2; 2; 2; 1] = [[-1;1]; [-2;2;2]; [1]] 901 | **) 902 | let groupAs f l = 903 | let rec aux f v l rl res = match l with 904 | | [] -> (rev rl) :: res 905 | | (h::t) when (f h) = v -> aux f v t (h::rl) res 906 | | (h::t) -> aux f (f h) t [h] ((rev rl) :: res) in 907 | match l with [] -> [] 908 | | (h::t) -> rev @@ aux f (f h) t [h] [] 909 | (**T 910 | groupAs (fun x -> x*x) [-1; 1; -2; 2; 2; 1] = [[-1;1]; [-2;2;2]; [1]] 911 | **) 912 | let group l = groupAs id l 913 | (**T 914 | group [1;1;2;2;3;1] = [[1;1]; [2;2]; [3]; [1]] 915 | **) 916 | let count p l = 917 | let rec aux c p l = match l with 918 | | [] -> c 919 | | (h::t) -> aux (c + (if p h then 1 else 0)) p t in 920 | aux 0 p l 921 | (**T 922 | count (gt 5) (0--10) = 5 923 | **) 924 | let rotate n l = 925 | let len = length l in 926 | let n = (-n) mod len in 927 | let n = if n >= 0 then n else len + n in 928 | uncurry (@) (reverseTuple (splitAt n l)) 929 | (**T 930 | rotate 1 [1;2;3] = [3;1;2] 931 | rotate 2 [1;2;3] = [2;3;1] 932 | rotate 3 [1;2;3] = [1;2;3] 933 | rotate (-1) [1;2;3] = [2;3;1] 934 | rotate (-2) [1;2;3] = [3;1;2] 935 | rotate (-3) [1;2;3] = [1;2;3] 936 | **) 937 | 938 | 939 | (* Array operations *) 940 | 941 | let auget = Array.unsafe_get 942 | let auset = Array.unsafe_set 943 | let amake = Array.make 944 | let acreate = Array.create 945 | let alen = Array.length 946 | (**T 947 | alen (1--|10) = 10 948 | **) 949 | let amap = Array.map 950 | (**T 951 | amap succ (1--|10) = (2--|11) 952 | **) 953 | let aiter = Array.iter 954 | let aconcat = Array.concat 955 | let ainit f l = Array.init l f 956 | (**T 957 | ainit succ 10 = (1--|10) 958 | **) 959 | let areverse a = 960 | let l = alen a in 961 | ainit (fun i -> auget a (l-1-i)) l 962 | let arev = areverse 963 | (**T 964 | arev (1--|10) = (10--|1) 965 | **) 966 | let afoldl = Array.fold_left 967 | let afoldl1 f a = 968 | let rec aux f i acc len a = 969 | if i >= len then acc 970 | else aux f (i+1) (f acc (auget a i)) len a in 971 | let len = alen a in 972 | if len < 1 then raise Not_found; 973 | aux f 1 (auget a 0) len a 974 | (**T 975 | afoldl1 (^) [|"foo"; "bar"; "baz"|] = "foobarbaz" 976 | afoldl1 dividef [|5.; 6.; 7.|] = dividef (dividef 5. 6.) 7. 977 | **) 978 | 979 | let afoldr f a i = Array.fold_right f i a 980 | let afoldr1 f a = 981 | let rec aux f i acc a = 982 | if i < 0 then acc 983 | else aux f (i-1) (f (auget a i) acc) a in 984 | let len = alen a in 985 | if len < 1 then raise Not_found; 986 | aux f (len-2) (auget a (len-1)) a 987 | (**T 988 | afoldr1 (^) [|"foo"; "bar"; "baz"|] = "foobarbaz" 989 | afoldr1 dividef [|5.; 6.; 7.|] = dividef 5. (dividef 6. 7.) 990 | **) 991 | 992 | let afilter f a = array (afoldr (fun i res -> if f i then i::res else res) [] a) 993 | (**T 994 | afilter (gt 3) (1--|5) = (4--|5) 995 | afilter (lt 3) (1--|5) = (1--|2) 996 | **) 997 | 998 | let asum a = afoldl1 (+) a 999 | (**T 1000 | asum [|1; 2; 3|] = 6 1001 | **) 1002 | let asumf a = afoldl1 (+.) a 1003 | (**T 1004 | asumf [|1.; 2.; 3.|] = 6. 1005 | **) 1006 | let aproduct a = afoldl1 ( * ) a 1007 | let aproductf a = afoldl1 ( *. ) a 1008 | let aaverage a = asum a / alen a 1009 | (**T 1010 | aaverage (1--|10) = 5 1011 | **) 1012 | let aaveragef a = asumf a /. float (alen a) 1013 | (**T 1014 | aaveragef (amap float (1--|10)) = 5.5 1015 | **) 1016 | 1017 | let arange s e = 1018 | if s > e 1019 | then ainit ((-) s) (s-e+1) 1020 | else ainit ((+) s) (e-s+1) 1021 | let (--|) = arange 1022 | (**T 1023 | (1--|3) = [|1;2;3|] 1024 | (3--|1) = [|3;2;1|] 1025 | (1--|1) = [|1|] 1026 | **) 1027 | let aZipWith f a b = 1028 | let len = min (alen a) (alen b) in 1029 | ainit (fun i -> 1030 | f (Array.unsafe_get a i) (Array.unsafe_get b i) 1031 | ) len 1032 | let amap2 = aZipWith 1033 | (**T 1034 | aZipWith (fun x y -> x / y) (1--|3) (4--|2) = [|0; 0; 1;|] 1035 | amap2 (+) (1--|10) (10--|1) = amake 10 11 1036 | **) 1037 | let arrayIndex i s = if i < 0 then (alen s) + i else i 1038 | let aslice i j s = 1039 | let i = arrayIndex i s 1040 | and j = arrayIndex j s + (if j < 0 then 1 else 0) in 1041 | let len = j - i in 1042 | Array.sub s i len 1043 | (**T 1044 | aslice 0 2 (1--|6) = (1--|2) 1045 | aslice 1 (-1) (1--|6) = (2--|6) 1046 | aslice 1 (-2) (1--|6) = (2--|5) 1047 | aslice (-3) (-2) (1--|6) = [|4; 5|] 1048 | aslice (-3) (-3) (1--|6) = [|4|] 1049 | aslice (-3) (-4) (1--|6) = [||] 1050 | maybeE true (fun v -> ignore (aslice (-3) (-5) v); false) (1--|6) 1051 | **) 1052 | let asub i len s = Array.sub s (arrayIndex i s) len 1053 | (**T 1054 | asub 0 2 (1--|6) = (1--|2) 1055 | asub 1 2 (1--|6) = (2--|3) 1056 | asub (-2) 2 (1--|6) = (5--|6) 1057 | maybeE true (fun v -> ignore (asub 3 (-1) v); false) (1--|6) 1058 | **) 1059 | let asubStride stride i len a = 1060 | let i = arrayIndex i a in 1061 | if i + (len-1) * stride >= alen a 1062 | then invalid_arg "Prelude.asubStride: index out of bounds"; 1063 | ainit (fun j -> auget a (i + j*stride)) len 1064 | (**T 1065 | asubStride 2 0 3 (1--|10) = [|1; 3; 5|] 1066 | asubStride 2 1 3 (1--|10) = [|2; 4; 6|] 1067 | asubStride 2 (-5) 3 (1--|10) = [|6; 8; 10|] 1068 | maybeE true (fun v -> ignore (asubStride 2 (-2) 2 v); false) (1--|6) 1069 | **) 1070 | let agroupsOf n a = 1071 | let count, rem = quot_rem (alen a) n in 1072 | unfoldrWhile (gte 0) (fun i -> asub (i*n) n a, i-1) (count-1) @ 1073 | if rem = 0 then [] else [asub (-rem) rem a] 1074 | (**T 1075 | agroupsOf 2 (1--|4) = [ 1--|2; 3--|4 ] 1076 | agroupsOf 2 (1--|6) = [ 1--|2; 3--|4; 5--|6 ] 1077 | agroupsOf 3 (1--|10) = [ 1--|3; 4--|6; 7--|9; [|10|] ] 1078 | **) 1079 | let asplitInto n range = 1080 | let len = alen range in 1081 | let plen = int (ceil (float len /. float n)) in 1082 | agroupsOf plen range 1083 | (**T 1084 | asplitInto 2 (1--|4) = [ 1--|2; 3--|4 ] 1085 | asplitInto 4 (1--|10) = [ 1--|3; 4--|6; 7--|9; [|10|] ] 1086 | **) 1087 | 1088 | 1089 | 1090 | (* String operations *) 1091 | 1092 | let suget = String.unsafe_get 1093 | let suset = String.unsafe_set 1094 | let smake = String.make 1095 | let screate = String.create 1096 | let sinit f l = 1097 | let s = String.create l in 1098 | for i=0 to l-1 do String.unsafe_set s i (f i) done; 1099 | s 1100 | let binit f l = 1101 | let s = String.create l in 1102 | for i=0 to l-1 do String.unsafe_set s i (chr (f i)) done; 1103 | s 1104 | let sreverse s = 1105 | let len = String.length s in 1106 | let s2 = String.create len in 1107 | let mlen = len - 1 in 1108 | for i=0 to mlen do 1109 | String.unsafe_set s2 (mlen-i) (String.unsafe_get s i) 1110 | done; 1111 | s2 1112 | let srev = sreverse 1113 | let slen = String.length 1114 | let stringIndex i s = if i < 0 then (slen s) + i else i 1115 | 1116 | let siter = String.iter 1117 | let smap f s = sinit (fun i -> suget s i) (slen s) 1118 | let sfilter f s = 1119 | let rec aux f s i res = 1120 | if i < 0 then implode res 1121 | else 1122 | let c = suget s i in 1123 | let res = if f c then c::res else res in 1124 | aux f s (i-1) res in 1125 | aux f s (slen s - 1) [] 1126 | 1127 | let biter f s = siter (fun c -> f (ord c)) s 1128 | let bmap f s = smap (fun c -> char (f (ord c))) s 1129 | let bfilter f s = sfilter (fun c -> f (ord c)) s 1130 | 1131 | let azipWith f a b = 1132 | let len = min (alen a) (alen b) in 1133 | ainit (fun i -> f (auget a i) (auget b i) ) len 1134 | let amap2 = azipWith 1135 | (**T 1136 | azipWith (+) (1--|3) (1--|4) = [| 2; 4; 6 |] 1137 | **) 1138 | 1139 | let szipWith f a b = 1140 | let len = min (slen a) (slen b) in 1141 | sinit (fun i -> f (suget a i) (suget b i) ) len 1142 | let smap2 = szipWith 1143 | (**T 1144 | szipWith (fun x y -> chr ((ord x + ord y) / 2)) "abc" "cde" = "bcd" 1145 | smap2 (fun x y -> x) "foo" "barq" = "foo" 1146 | **) 1147 | let bzipWith f a b = 1148 | let len = min (slen a) (slen b) in 1149 | sinit (fun i -> chr (f (ord (suget a i)) (ord (suget b i))) ) len 1150 | let bmap2 = bzipWith 1151 | (**T 1152 | bzipWith average2 "abc" "cde" = "bcd" 1153 | bmap2 (fun x y -> x) "foo" "bar" = "foo" 1154 | **) 1155 | 1156 | let implodeArray a = sinit (auget a) (alen a) 1157 | (**T 1158 | implodeArray [|'f'; 'o'; 'o'; 'b'; 'a'; 'r'|] = "foobar" 1159 | implodeArray (explodeArray "") = "" 1160 | implodeArray (explodeArray "foo") = "foo" 1161 | **) 1162 | let explodeArray s = ainit (suget s) (slen s) 1163 | (**T 1164 | explodeArray "foobar" = [|'f'; 'o'; 'o'; 'b'; 'a'; 'r'|] 1165 | explodeArray "" = [||] 1166 | **) 1167 | let char_array = explodeArray 1168 | 1169 | let byte_array s = ainit (fun i -> ord (suget s i)) (slen s) 1170 | 1171 | let sfoldl f init s = 1172 | let rec aux f s len v i = 1173 | if i >= len then v else aux f s len (f v (suget s i)) (i+1) in 1174 | aux f s (slen s) init 0 1175 | let sfoldl1 f a = 1176 | let rec aux f i acc len a = 1177 | if i >= len then acc 1178 | else aux f (i+1) (f acc (suget a i)) len a in 1179 | let len = slen a in 1180 | if len < 1 then raise Not_found; 1181 | aux f 1 (suget a 0) len a 1182 | let sfoldr f init s = 1183 | let rec aux f s v i = 1184 | if i < 0 then v else aux f s (f (suget s i) v) (i-1) in 1185 | aux f s init (slen s - 1) 1186 | let sfoldr1 f a = 1187 | let rec aux f i acc a = 1188 | if i < 0 then acc 1189 | else aux f (i-1) (f (suget a i) acc) a in 1190 | let len = slen a in 1191 | if len < 1 then raise Not_found; 1192 | aux f (len-2) (suget a (len-1)) a 1193 | 1194 | let bfoldl f init s = 1195 | let rec aux f s len v i = 1196 | if i >= len then v else aux f s len (f v (ord (suget s i))) (i+1) in 1197 | aux f s (slen s) init 0 1198 | let bfoldl1 f a = 1199 | let rec aux f i acc len a = 1200 | if i >= len then acc 1201 | else aux f (i+1) (f acc (ord (suget a i))) len a in 1202 | let len = slen a in 1203 | if len < 1 then raise Not_found; 1204 | aux f 1 (ord (suget a 0)) len a 1205 | let bfoldr f init s = 1206 | let rec aux f s v i = 1207 | if i < 0 then v else aux f s (f (ord (suget s i)) v) (i-1) in 1208 | aux f s init (slen s - 1) 1209 | let bfoldr1 f a = 1210 | let rec aux f i acc a = 1211 | if i < 0 then acc 1212 | else aux f (i-1) (f (ord (suget a i)) acc) a in 1213 | let len = slen a in 1214 | if len < 1 then raise Not_found; 1215 | aux f (len-2) (ord (suget a (len-1))) a 1216 | 1217 | let substring i len s = String.sub s (stringIndex i s) len 1218 | (**T 1219 | substring 0 2 "foobar" = "fo" 1220 | substring 1 2 "foobar" = "oo" 1221 | substring (-2) 2 "foobar" = "ar" 1222 | maybeE true (fun v -> ignore (substring 3 (-1) v); false) "foobar" 1223 | **) 1224 | let ssub = substring 1225 | 1226 | let sgroupsOf n a = 1227 | let count, rem = quot_rem (slen a) n in 1228 | unfoldrWhile (gte 0) (fun i -> ssub (i*n) n a, i-1) (count-1) @ 1229 | if rem = 0 then [] else [ssub (-rem) rem a] 1230 | (**T 1231 | sgroupsOf 2 "foobar" = [ "fo"; "ob"; "ar" ] 1232 | sgroupsOf 3 "foobarbazq" = [ "foo"; "bar"; "baz"; "q" ] 1233 | **) 1234 | let ssplitInto n range = 1235 | let len = slen range in 1236 | let plen = int (ceil (float len /. float n)) in 1237 | sgroupsOf plen range 1238 | (**T 1239 | ssplitInto 2 "foobar" = [ "foo"; "bar" ] 1240 | ssplitInto 4 "foobar" = [ "fo"; "ob"; "ar" ] 1241 | ssplitInto 4 "foobarbazq" = [ "foo"; "bar"; "baz"; "q" ] 1242 | **) 1243 | 1244 | let ssum a = bfoldl (+) 0 a 1245 | (**T 1246 | ssum "\001\002\003" = 6 1247 | **) 1248 | let ssumf a = float (bfoldl (+) 0 a) 1249 | (**T 1250 | ssumf "\001\002\003" = 6. 1251 | **) 1252 | let saverage a = ssum a / slen a 1253 | (**T 1254 | saverage "ABC" = 66 1255 | **) 1256 | let saveragef a = ssumf a /. float (slen a) 1257 | (**T 1258 | saveragef "ABC" = 66. 1259 | **) 1260 | let ssubStride stride i len a = 1261 | let i = stringIndex i a in 1262 | if i + (len-1) * stride >= slen a 1263 | then invalid_arg "Prelude.ssubStride: index out of bounds"; 1264 | sinit (fun j -> suget a (i + j*stride)) len 1265 | 1266 | let strip = Pcre.replace ~rex:(Pcre.regexp "^\\s+|\\s+$") ~templ:"" 1267 | 1268 | let split ?n sep s = Pcre.split ?max:n ~pat:sep s 1269 | let rsplit ?n sep s = rev @@ map srev @@ split ?n sep @@ srev s 1270 | let nsplit sep n s = split ~n sep s 1271 | let nrsplit sep n s = rsplit ~n sep s 1272 | 1273 | let rx = Pcre.regexp 1274 | let rex = Pcre.regexp 1275 | let escape_rex = Pcre.quote 1276 | 1277 | let rexsplit ?n rex s = 1278 | map (function Pcre.Text s -> s | _ -> "") @@ 1279 | filter (function Pcre.Text _ -> true | _ -> false) @@ 1280 | Pcre.full_split ?max:n ~rex s 1281 | let rexrsplit ?n rex s = rev @@ map srev @@ rexsplit ?n rex @@ srev s 1282 | let xsplit ?n rexs s = rexsplit ?n (rx rexs) s 1283 | let xrsplit ?n rexs s = rexrsplit ?n (rx rexs) s 1284 | let xnsplit rexs n s = xsplit ~n rexs s 1285 | let xnrsplit rexs n s = xrsplit ~n rexs s 1286 | 1287 | let rexscan rex s = 1288 | try Array.to_list @@ Array.map Array.to_list @@ Pcre.extract_all ~rex s 1289 | with _ -> [] 1290 | let scan rexs s = rexscan (rx rexs) s 1291 | 1292 | let rexscan_nth rex n s = 1293 | try 1294 | let arr = Pcre.extract_all ~rex s in 1295 | list (amap (fun a -> 1296 | if alen a <= n 1297 | then invalid_arg "Prelude.rexscan_nth: index out of bounds"; 1298 | a.(n) 1299 | ) arr) 1300 | with _ -> [] 1301 | let scan_nth rexs n s = rexscan_nth (rx rexs) n s 1302 | 1303 | let xfind x s = first (scan_nth x 0 s) 1304 | let xfindOpt x s = optNF first (scan_nth x 0 s) 1305 | 1306 | let smatch pat = Pcre.pmatch ~pat 1307 | let rexmatch rex = Pcre.pmatch ~rex 1308 | let xmatch s = rexmatch (rx s) 1309 | 1310 | let sreplace pat templ = Pcre.replace ~pat ~templ 1311 | let rexreplace rex templ = Pcre.replace ~rex ~templ 1312 | let xreplace s = rexreplace (rx s) 1313 | 1314 | let frexreplace f rex s = 1315 | let split = Pcre.full_split ~rex s in 1316 | let processed = map (function 1317 | | Pcre.Text s -> s 1318 | | Pcre.Delim s -> f s 1319 | | _ -> "") split in 1320 | String.concat "" processed 1321 | let fxreplace f s = frexreplace f (rx s) 1322 | 1323 | let quote l r s = l ^ s ^ r 1324 | let join = String.concat 1325 | 1326 | let xreplaceMulti x_rep s = 1327 | let pat = x_rep |> map (quote "(" ")" @. fst) |> join "|" in 1328 | frexreplace (fun p -> assocBy (fun x -> xmatch x p) x_rep) (rex pat) s 1329 | (**T 1330 | xreplaceMulti ["f.o","bar"; "b.r","foo"] "foobar" = "barfoo" 1331 | xreplaceMulti ["f.o","bar"; "bar","foo"] "foobar" = "barfoo" 1332 | **) 1333 | 1334 | let sreplaceMulti pat_rep s = 1335 | let pat = pat_rep |> map fst |> map escape_rex |> join "|" in 1336 | frexreplace (flip assoc pat_rep) (rex pat) s 1337 | (**T 1338 | sreplaceMulti ["foo","bar"; "bar","foo"] "foobar" = "barfoo" 1339 | sreplaceMulti ["f.o","bar"; "bar","foo"] "foobar" = "foofoo" 1340 | **) 1341 | 1342 | let ajoin s a = join s (Array.to_list a) 1343 | let uppercase = String.uppercase 1344 | let lowercase = String.lowercase 1345 | let capitalize = String.capitalize 1346 | let sslice i j s = 1347 | let i = stringIndex i s 1348 | and j = stringIndex j s + (if j < 0 then 1 else 0) in 1349 | let len = j - i in 1350 | String.sub s i len 1351 | (**T 1352 | sslice 0 2 "foobar" = "fo" 1353 | sslice 1 (-1) "foobar" = "oobar" 1354 | sslice 1 (-2) "foobar" = "ooba" 1355 | sslice (-3) (-2) "foobar" = "ba" 1356 | sslice (-3) (-3) "foobar" = "b" 1357 | sslice (-3) (-4) "foobar" = "" 1358 | maybeE true (fun v -> ignore (sslice (-3) (-5) v); false) "foobar" 1359 | **) 1360 | let ssumSub i len a = 1361 | let rec aux s i l c = 1362 | if l = 0 then c else 1363 | aux s (i+1) (l-1) (c + ord (suget s i)) in 1364 | if i < 0 || len < 0 || i + len > slen a 1365 | then invalid_arg "Prelude.ssumSub: index ouf of bounds" 1366 | else aux a i len 0 1367 | (**T 1368 | ssumSub 0 3 "foo" = ssum "foo" 1369 | ssumSub 0 3 "foobar" = ssum "foo" 1370 | ssumSub 3 3 "foobar" = ssum "bar" 1371 | maybeE true (fun s -> ignore @@ ssumSub (-1) 3 s; false) "foo" 1372 | maybeE true (fun s -> ignore @@ ssumSub 1 3 s; false) "foo" 1373 | **) 1374 | let ssumSubf i len a = float (ssumSub i len a) 1375 | let ssumSlice i j s = 1376 | let i = stringIndex i s 1377 | and j = stringIndex j s + (if j < 0 then 1 else 0) in 1378 | let len = j - i in 1379 | ssumSub i len s 1380 | (**T 1381 | ssumSlice 0 3 "foo" = ssum "foo" 1382 | ssumSlice 0 3 "foobar" = ssum "foo" 1383 | ssumSlice 3 3 "foobar" = ssum "" 1384 | ssumSlice 3 (-1) "foobar" = ssum "bar" 1385 | maybeE true (fun s -> ignore @@ ssumSlice 1 4 s; false) "foo" 1386 | **) 1387 | let ssumSlicef i len a = float (ssumSlice i len a) 1388 | let saverageSub i len a = ssumSub i len a / len 1389 | (**T 1390 | saverageSub 0 3 "foo" = saverage "foo" 1391 | saverageSub 0 3 "foobar" = saverage "foo" 1392 | saverageSub 3 3 "foobar" = saverage "bar" 1393 | **) 1394 | let saverageSubf i len a = ssumSubf i len a /. float len 1395 | (**T 1396 | saverageSubf 0 3 "foo" = saveragef "foo" 1397 | saverageSubf 0 3 "foobar" = saveragef "foo" 1398 | saverageSubf 3 3 "foobar" = saveragef "bar" 1399 | **) 1400 | let saverageSlice i j s = 1401 | let i = stringIndex i s 1402 | and j = stringIndex j s + (if j < 0 then 1 else 0) in 1403 | let len = j - i in 1404 | ssumSub i len s / len 1405 | (**T 1406 | saverageSlice 0 3 "foo" = saverage "foo" 1407 | saverageSlice 0 3 "foobar" = saverage "foo" 1408 | saverageSlice 3 (-1) "foobar" = saverage "bar" 1409 | **) 1410 | let saverageSlicef i j s = 1411 | let i = stringIndex i s 1412 | and j = stringIndex j s + (if j < 0 then 1 else 0) in 1413 | let len = j - i in 1414 | float (ssumSub i len s) /. float len 1415 | (**T 1416 | saverageSlicef 0 3 "foo" = saveragef "foo" 1417 | saverageSlicef 0 3 "foobar" = saveragef "foo" 1418 | saverageSlicef 3 (-1) "foobar" = saveragef "bar" 1419 | **) 1420 | 1421 | let words s = rexsplit (rx "\\s+") s 1422 | let unwords a = join " " a 1423 | 1424 | let lines s = split "\n" s 1425 | let unlines a = join "\n" a ^ "\n" 1426 | 1427 | let rexsplitPartition rex s = 1428 | let rec aux splits l = match splits with 1429 | | [] -> (rev l, None) 1430 | | (a::[]) -> (rev l, Some a) 1431 | | (a::b::t) -> aux t ((a,b)::l) in 1432 | let cleaned_split = 1433 | Pcre.full_split ~rex s |> 1434 | filter (function Pcre.Text _ | Pcre.Delim _ -> true | _ -> false) in 1435 | let padded_split = match cleaned_split with 1436 | | (Pcre.Delim _ :: t) -> (Pcre.Text "") :: cleaned_split 1437 | | _ -> cleaned_split in 1438 | let string_split = 1439 | map (function Pcre.Text s | Pcre.Delim s -> s | _ -> "") padded_split in 1440 | aux string_split [] 1441 | let xsplitPartition x s = rexsplitPartition (rex x) s 1442 | 1443 | let pickStr indices l = explode l |> pick indices 1444 | let pickStrWith funcs l = explode l |> pickWith funcs 1445 | 1446 | 1447 | (* File and IO operations *) 1448 | 1449 | let putStr = print_string 1450 | let putStrLn = print_endline 1451 | let puts s = if rexmatch (rx "\n$") s 1452 | then print_string s 1453 | else print_endline s 1454 | let output_line oc line = 1455 | output_string oc line; 1456 | output_char oc '\n' 1457 | 1458 | let readLine = input_line 1459 | let readChar = input_char 1460 | let readByte = input_byte 1461 | let readInt = readLine |>. parseInt 1462 | let readFloat = readLine |>. parseFloat 1463 | 1464 | let open_append = open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] 0o666 1465 | let open_append_bin = open_out_gen [Open_wronly; Open_creat; Open_append; Open_binary] 0o666 1466 | 1467 | let fileExists = Sys.file_exists 1468 | 1469 | let finally finaliser f x = 1470 | let r = try f x with e -> 1471 | ( try finaliser x with _ -> () ); 1472 | raise e in 1473 | finaliser x; 1474 | r 1475 | 1476 | let withFile filename f = finally close_in f (open_in_bin filename) 1477 | let withFileOut filename f = finally close_out f (open_out_bin filename) 1478 | let withFileAppend filename f = finally close_out f (open_append_bin filename) 1479 | 1480 | let withUnixFile ?(flags=[Unix.O_RDONLY]) ?(perm=0o644) fn f = 1481 | finally Unix.close f (Unix.openfile fn flags perm) 1482 | let withUnixFileOut ?(flags=[Unix.O_WRONLY;Unix.O_TRUNC;Unix.O_CREAT]) ?(perm=0o644) fn f = 1483 | finally Unix.close f (Unix.openfile fn flags perm) 1484 | let withUnixFileAppend ?(flags=[Unix.O_APPEND;Unix.O_CREAT]) ?(perm=0o644) fn f = 1485 | finally Unix.close f (Unix.openfile fn flags perm) 1486 | 1487 | 1488 | let read ?buf bytes ch = 1489 | let rec aux ch bytes c buf = 1490 | match input ch buf c (bytes-c) with 1491 | | 0 when c = 0 -> raise End_of_file 1492 | | 0 -> String.sub buf 0 c 1493 | | b when c + b = bytes -> buf 1494 | | b -> aux ch bytes (c+b) buf in 1495 | let buf = match buf with 1496 | | None -> String.create bytes 1497 | | Some s -> 1498 | if slen s = bytes then s 1499 | else invalid_arg (sprintf 1500 | "Prelude.read: buffer size %d differs from read size %d" 1501 | (slen s) bytes) in 1502 | aux ch bytes 0 buf 1503 | 1504 | let write = output_string 1505 | 1506 | let readAll ch = 1507 | let rec aux ch ret buf = 1508 | match input ch buf 0 4096 with 1509 | | 0 -> Buffer.contents ret 1510 | | b -> Buffer.add_substring ret buf 0 b; 1511 | aux ch ret buf in 1512 | let ret = Buffer.create 4096 in 1513 | let buf = String.create 4096 in 1514 | aux ch ret buf 1515 | 1516 | let stat = Unix.stat 1517 | 1518 | let fileSize filename = (stat filename).Unix.st_size 1519 | 1520 | let fileKind fn = (stat fn).Unix.st_kind 1521 | let isKind kind fn = fileKind fn = kind 1522 | let isDir = isKind Unix.S_DIR 1523 | let isFile = isKind Unix.S_REG 1524 | let isLink = isKind Unix.S_LNK 1525 | let isFIFO = isKind Unix.S_FIFO 1526 | let isSocket = isKind Unix.S_SOCK 1527 | let isCharDev = isKind Unix.S_CHR 1528 | let isBlockDev = isKind Unix.S_BLK 1529 | 1530 | let fileInode fn = (stat fn).Unix.st_ino 1531 | let filePermissions fn = (stat fn).Unix.st_perm 1532 | let fileDevice fn = (stat fn).Unix.st_dev 1533 | let fileOwner fn = (stat fn).Unix.st_uid 1534 | let fileGroup fn = (stat fn).Unix.st_gid 1535 | 1536 | let atime fn = (stat fn).Unix.st_atime 1537 | let mtime fn = (stat fn).Unix.st_mtime 1538 | let ctime fn = (stat fn).Unix.st_ctime 1539 | 1540 | let readFile filename = withFile filename readAll 1541 | let writeFile filename str = withFileOut filename (flip output_string str) 1542 | let appendFile filename str = withFileAppend filename (flip output_string str) 1543 | 1544 | let readLines = lines @. readFile 1545 | 1546 | let tokenize t ic = unfoldlOpt (maybeEOF None (fun ic -> Some (t ic, ic))) ic 1547 | let tokenizeN t n ic = unfoldlN t n ic 1548 | let tokenizeIter t f ic = maybeEOF () (loop (f @. t)) ic 1549 | let tokenizeMap t f ic = tokenize (f @. t) ic 1550 | let tokenizeFile t filename = withFile filename (tokenize t) 1551 | let tokenizeFileN t n fn = withFile fn (tokenizeN t n) 1552 | 1553 | let icEachLine f ic = tokenizeIter input_line f ic 1554 | let icMapLines f ic = tokenizeMap input_line f ic 1555 | let eachLine f = flip withFile (icEachLine f) 1556 | let mapLines f = flip withFile (icMapLines f) 1557 | 1558 | let output_line_flush oc s = output_line oc s; flush oc 1559 | 1560 | 1561 | (* Filesystem paths *) 1562 | 1563 | (**T 1564 | (* Simple relative *) 1565 | expand_path "foo" = (Filename.concat (Unix.getcwd ()) "foo") 1566 | 1567 | (* Absolute *) 1568 | expand_path "/foo" = "/foo" 1569 | 1570 | (* /./ *) 1571 | expand_path "/foo/./bar/./baz/./" = "/foo/bar/baz" 1572 | 1573 | (* /. *) 1574 | expand_path "/foo/bar/." = "/foo/bar" 1575 | 1576 | (* /../ *) 1577 | expand_path "/foo/../bar/../baz" = "/baz" 1578 | 1579 | (* /../ 2 *) 1580 | expand_path "/foo/../bar/../baz/../" = "/" 1581 | 1582 | (* /.. *) 1583 | expand_path "/foo/bar/.." = "/foo" 1584 | 1585 | (* Mixed /./ and /../ *) 1586 | expand_path "/foo/../bar/./baz/qux/./.." = "/bar/baz" 1587 | 1588 | (* Trailing / (absolute) *) 1589 | expand_path "/foo/" = "/foo" 1590 | 1591 | (* Trailing / (relative) *) 1592 | expand_path "foo/" = (Filename.concat (Unix.getcwd ()) "foo") 1593 | 1594 | (* Root *) 1595 | expand_path "/" = "/" 1596 | 1597 | (* Current dir *) 1598 | expand_path "" = (Unix.getcwd ()) 1599 | **) 1600 | let expand_path path = 1601 | let rec replace re tmpl s = 1602 | let s' = Pcre.replace ~rex:(Pcre.regexp re) ~templ:tmpl s in 1603 | if s = s' then s 1604 | else replace re tmpl s' in 1605 | let p1 = if not (Filename.is_relative path) then path 1606 | else Filename.concat (Sys.getcwd ()) path in 1607 | let p2 = replace "/\\.(/|$)" "/" p1 in 1608 | let p3 = replace "/[^/]+/\\.\\.(/|$)" "/" p2 in 1609 | if String.length p3 > 1 1610 | then replace "/$" "" p3 1611 | else p3 1612 | 1613 | module Path = 1614 | struct 1615 | type t = Path of string list 1616 | 1617 | let absolute a = 1618 | let rec aux a lst = match a with 1619 | | [] -> rev lst 1620 | | (""::t) -> aux t [""] 1621 | | (".."::t) -> aux t (maybeNF [] tail lst) 1622 | | (h::t) -> aux t (h::lst) in 1623 | aux a [] 1624 | let make s = 1625 | let s = xreplace "/+" "/" s in 1626 | let s = xreplace "/$" "" s in 1627 | Path (split "/" s) 1628 | let to_s (Path a) = if a = [""] then "/" else join "/" a 1629 | 1630 | let join_path (Path a) (Path b) = Path (absolute (a @ b)) 1631 | 1632 | let join_list path ss = foldl join_path path (map make ss) 1633 | let join path s = join_path path (make s) 1634 | 1635 | let join_list_to_s path ss = to_s (join_list path ss) 1636 | let join_to_s path s = to_s (join path s) 1637 | 1638 | let expand path = make (expand_path (to_s path)) 1639 | end 1640 | (**T 1641 | Path.to_s (Path.make "/home") = "/home" 1642 | Path.to_s (Path.make "/home/foo") = "/home/foo" 1643 | Path.to_s (Path.make "/home/") = "/home" 1644 | Path.to_s (Path.join (Path.make "/home/") "foo") = "/home/foo" 1645 | Path.to_s (Path.join (Path.make "/home/") "/foo") = "/foo" 1646 | Path.to_s (Path.join (Path.make "/home/") "..") = "/" 1647 | Path.to_s (Path.join_list (Path.make "/home/") [".."; "tmp"]) = "/tmp" 1648 | Path.join_to_s (Path.make "/home/") "/foo" = "/foo" 1649 | Path.join_to_s (Path.make "/home/") ".." = "/" 1650 | Path.join_list_to_s (Path.make "/home/") [".."; "tmp"] = "/tmp" 1651 | **) 1652 | 1653 | let expandPath = expand_path 1654 | 1655 | let (^/) = Filename.concat 1656 | let dirExists d = fileExists d && isDir d 1657 | let isRoot d = fileInode d = fileInode "/" && fileDevice d = fileDevice "/" 1658 | let parentDirs d = 1659 | generateUntil (eq "") (nrsplit "/" 2 |>. first) (expandPath d) @ ["/"] 1660 | 1661 | let dirSeparator = sslice 1 (-2) ("a" ^/ "b") 1662 | let splitPath p = match p with 1663 | | "/" -> ["/"] 1664 | | p -> 1665 | begin match split dirSeparator p with 1666 | | (""::t) -> "/"::t 1667 | | ps -> ps 1668 | end 1669 | let joinPath ps = foldl1 (^/) ps 1670 | (**T 1671 | joinPath (splitPath "/foo/bar/baz") = "/foo/bar/baz" 1672 | joinPath (splitPath "/foo/") = "/foo" 1673 | joinPath (splitPath "/foo") = "/foo" 1674 | joinPath (splitPath "/") = "/" 1675 | **) 1676 | let relativePath path = 1677 | let cp = splitPath (expandPath ".") in 1678 | let pp = splitPath (expandPath path) in 1679 | let cp, pp = dropWhile2 (=) cp pp in 1680 | joinPath (replicate (len cp) ".." @ pp) 1681 | 1682 | let dirname = Filename.dirname 1683 | let basename = Filename.basename 1684 | 1685 | 1686 | (* Running commands *) 1687 | 1688 | let shell_escape = 1689 | let re = Pcre.regexp "(?=[^a-zA-Z0-9._+/-])" in 1690 | Pcre.replace ~rex:re ~templ:"\\" 1691 | 1692 | let escape_cmd args = join " " (map shell_escape args) 1693 | 1694 | exception Command_error of int * string 1695 | let command args = 1696 | let cmd = escape_cmd args in 1697 | let retcode = Sys.command cmd in 1698 | if retcode <> 0 then 1699 | raise (Command_error (retcode, (sprintf "Command failed with %d: %S" retcode cmd))) 1700 | else 1701 | () 1702 | 1703 | let runCmd = command 1704 | let cmdCode args = try command args; 0 with Command_error (rv,_) -> rv 1705 | 1706 | let withRawCmd cmd f = 1707 | let ic,oc = Unix.open_process cmd in 1708 | finally (fun _ -> maybeE () close_out oc; maybeE () close_in ic) 1709 | (f ic) oc 1710 | let withRawCmdStdin args f = 1711 | withRawCmd args (fun ic oc -> maybeE () close_in ic; f oc) 1712 | let withRawCmdStdout args f = 1713 | withRawCmd args (fun ic oc -> maybeE () close_out oc; f ic) 1714 | 1715 | let withCmd args = withRawCmd (escape_cmd args) 1716 | let withCmdStdin args = withRawCmdStdin (escape_cmd args) 1717 | let withCmdStdout args = withRawCmdStdout (escape_cmd args) 1718 | 1719 | let readCmd args = withCmdStdout args readAll 1720 | let readRawCmd args = withRawCmdStdout args readAll 1721 | 1722 | 1723 | (* IO piping *) 1724 | 1725 | let pipeWith f init i o = recurseOpt (f i o) init 1726 | let pipeChan f = pipeWith (optEOF @.. f) 1727 | let unitPipe t f = t (fun ic () -> f ic, ()) 1728 | let pipeTokenizer input output f ic oc init = 1729 | let line, acc = f (input ic) init in 1730 | output oc line; 1731 | acc 1732 | 1733 | let linePiper = pipeTokenizer input_line output_line_flush 1734 | let blockPiper ?buf block_sz = pipeTokenizer (read ?buf block_sz) write 1735 | 1736 | let pipeLines f = pipeChan (linePiper f) 1737 | let pipeBlocks block_sz f = 1738 | let buf = String.create block_sz in 1739 | pipeChan (blockPiper ~buf block_sz f) 1740 | 1741 | let withFiles f infile outfile = 1742 | withFile infile (fun ic -> withFileOut outfile (fun oc -> f ic oc)) 1743 | let withFilesAppend f infile outfile = 1744 | withFile infile (fun ic -> withFileAppend outfile (fun oc -> f ic oc)) 1745 | 1746 | let pipeFiles f init = withFiles (pipeChan f init) 1747 | let pipeFileLines f init = withFiles (pipeLines f init) 1748 | let pipeFileBlocks block_sz f init = withFiles (pipeBlocks block_sz f init) 1749 | 1750 | let pipeAppend f init = withFilesAppend (pipeChan f init) 1751 | let pipeAppendLines f init = withFilesAppend (pipeLines f init) 1752 | let pipeAppendBlocks block_sz f init = withFilesAppend (pipeBlocks block_sz f init) 1753 | 1754 | let interactWith f = pipeChan (unitPipe linePiper f) () 1755 | let interact f = interactWith f stdin stdout 1756 | let interactFiles f = pipeFiles (unitPipe linePiper f) () 1757 | let interactAppend f = pipeAppend (unitPipe linePiper f) () 1758 | 1759 | let pipeCmd f init args = withCmd args (pipeChan f init) 1760 | let pipeCmdLines f init args = withCmd args (pipeLines f init) 1761 | let interactWithCmd f args = withCmd args (interactWith f) 1762 | 1763 | let pipeRawCmd f init args = withRawCmd args (pipeChan f init) 1764 | let pipeRawCmdLines f init args = withRawCmd args (pipeLines f init) 1765 | let interactWithRawCmd f args = withRawCmd args (interactWith f) 1766 | 1767 | 1768 | (* Common filesystem operations *) 1769 | 1770 | let rename = Sys.rename 1771 | 1772 | let ls d = Array.to_list (Sys.readdir d) 1773 | let rm = Sys.remove 1774 | let cp s d = pipeFileBlocks 4096 tuple () s d 1775 | let mv s d = 1776 | try rename s d 1777 | with Sys_error "Invalid cross-device link" -> cp s d; rm s 1778 | let ln_s = Unix.symlink 1779 | let ln = Unix.link 1780 | let mkdir ?(perm=0o755) s = Unix.mkdir s perm 1781 | let rmdir = Unix.rmdir 1782 | let mkdir_p ?(perm=0o755) s = 1783 | let nex, ex = span (not @. fileExists) (parentDirs s) in 1784 | iter (mkdir ~perm) (reverse nex) 1785 | 1786 | let getcwd = Sys.getcwd 1787 | let pwd = Sys.getcwd 1788 | let chdir = Unix.chdir 1789 | let cd = Unix.chdir 1790 | 1791 | let chmod perm fn = Unix.chmod fn perm 1792 | 1793 | 1794 | (* Time *) 1795 | 1796 | let timeNow = Unix.gettimeofday 1797 | let timeZone = Netdate.localzone 1798 | let formatTime ?(zone=timeZone) fmt f = Netdate.format ~fmt (Netdate.create ~zone f) 1799 | let showTime = formatTime "%Y-%m-%d %H:%M:%S%z" 1800 | let showDate = formatTime "%Y-%m-%d" 1801 | let httpDate = formatTime ~zone:0 "%a, %d %b %Y %H:%M:%S GMT" 1802 | 1803 | let second = 1.0 1804 | let minute = 60.0 *. second 1805 | let hour = 60.0 *. minute 1806 | let day = 24.0 *. hour 1807 | let week = 7.0 *. day 1808 | let month = 31.0 *. day 1809 | let year = 365.0 *. day 1810 | 1811 | let sleep = Unix.sleep 1812 | 1813 | 1814 | (* Extra file operations *) 1815 | 1816 | let withTempFile suffix f = 1817 | let tmpfilename _ = 1818 | "/tmp" ^/ (showInt (Random.int 1000000) ^ showFloat (timeNow ()) ^ "." ^ suffix) in 1819 | let fn = (0--1000) 1820 | |> find (fun i -> not (fileExists (tmpfilename i))) 1821 | |> tmpfilename in 1822 | finally (fun fn -> if fileExists fn then rm fn else ()) f fn 1823 | 1824 | let appendFileTo oc filename = 1825 | withFile filename (fun ic -> pipeBlocks 4096 tuple () ic oc) 1826 | 1827 | let prependFile filename str = 1828 | if fileSize filename > 32000000 (* use temp file if larger than 32 megs *) 1829 | then withTempFile filename (fun fn -> 1830 | withFileOut fn (fun oc -> write oc str; appendFileTo oc filename); 1831 | mv fn filename) 1832 | else writeFile filename (str ^ readFile filename) 1833 | 1834 | --------------------------------------------------------------------------------