├── .gitignore ├── INSTALL.sh ├── Makefile ├── README.md ├── UNLICENSE └── code ├── Makefile ├── async ├── #build_other_searches.sh# ├── #main.topscript# ├── better_echo.ml ├── build_echo.sh ├── build_other_searches.sh ├── echo.ml ├── main-35.rawscript ├── main-38.rawscript ├── main-44.rawscript ├── main-45.rawscript ├── main-46.rawscript ├── main-47.rawscript ├── main.topscript ├── native_code_log_delays.ml ├── pipe_write_break.rawscript ├── pipe_write_break.rawtopscript ├── run_echo.rawsh ├── run_native_code_log_delays.rawsh ├── run_native_code_log_delays_orig.sh ├── run_search.rawsh ├── run_search_orig.sh ├── run_search_with_configurable_server.rawsh ├── run_search_with_configurable_server_orig.errsh ├── run_search_with_error_handling.rawsh ├── run_search_with_error_handling_orig.sh ├── run_search_with_timeout_no_leak.rawsh ├── run_search_with_timeout_no_leak_orig.sh ├── run_thread.sh ├── search.ml ├── search_out_of_order.ml ├── search_with_configurable_server.ml ├── search_with_error_handling.ml ├── search_with_error_handling_deprecated.ml ├── search_with_timeout.ml ├── search_with_timeout_choice.ml ├── search_with_timeout_no_leak.ml ├── search_with_timeout_no_leak_simple.ml ├── search_with_timeout_simple.ml ├── test.txt ├── thread_exp_async_busy_loop.ml ├── thread_exp_async_busy_loop_in_thread.ml ├── thread_exp_async_noalloc_busy_loop.ml ├── thread_exp_async_noalloc_busy_loop_in_thread.ml ├── thread_exp_async_only.ml ├── thread_exp_common.ml ├── thread_experiments.ml └── timeout_search.ml ├── back-end-bench ├── alternate_list.ml ├── bench_patterns.ml ├── bench_poly_and_mono.ml ├── run_alternate_list.sh ├── run_bench_patterns.sh └── run_bench_poly_and_mono.sh ├── back-end-embed ├── build_embed.sh ├── build_embed_binary.rawsh ├── build_embed_c.sh ├── build_embed_native.rawsh ├── embed_me1.ml ├── embed_me2.ml ├── embed_out.c ├── hello.ml ├── link_custom.rawsh ├── link_dllib.rawsh ├── main.c ├── run_debug_hello.sh ├── xbuild_embed_binary.sh └── xbuild_embed_native.sh ├── back-end ├── alternate_list.ml ├── asm_from_compare_mono.sh ├── barrier_bench.ml ├── cmp.S ├── compare_mono.ml ├── compare_mono.s ├── compare_poly.ml ├── compare_poly_asm.S ├── gdb_alternate0.rawsh ├── gdb_alternate1.rawsh ├── gdb_alternate2.rawsh ├── gdb_alternate3.rawsh ├── instr_for_pattern_monomorphic_small.sh ├── lambda_for_pattern_monomorphic_large.sh ├── lambda_for_pattern_monomorphic_small.sh ├── lambda_for_pattern_polymorphic.sh ├── opam_switch.rawsh ├── pattern_monomorphic_large.ml ├── pattern_monomorphic_small.ml ├── pattern_polymorphic.ml ├── perf_record.rawsh └── perf_report.rawsh ├── classes-async ├── build_shapes.sh ├── multiple_inheritance.ml ├── multiple_inheritance_wrong.ml ├── shapes.ml └── verbose_shapes.ml ├── classes ├── Iterator.java ├── binary.topscript ├── binary_larger.ml ├── binary_module.ml ├── build_doc.sh ├── citerator.cpp ├── class_types_stack.ml ├── doc.ml ├── initializer.topscript ├── istack.topscript ├── iter.topscript └── stack.topscript ├── code ├── command-line-parsing ├── _tags ├── basic.topscript ├── basic_md5.ml ├── basic_md5_as_filename.ml ├── basic_md5_sequence.ml ├── basic_md5_succinct.ml ├── basic_md5_with_custom_arg.ml ├── basic_md5_with_default_file.ml ├── basic_md5_with_flags.ml ├── basic_md5_with_opt_flags.ml ├── basic_md5_with_optional_file.ml ├── basic_md5_with_optional_file_broken.ml ├── build_and_run_cal_add_interactive.rawsh ├── build_basic_md5.sh ├── build_basic_md5_as_filename.sh ├── build_basic_md5_sequence.sh ├── build_basic_md5_with_custom_arg.sh ├── build_basic_md5_with_default_file.sh ├── build_basic_md5_with_flags.sh ├── build_basic_md5_with_opt_flags.sh ├── build_basic_md5_with_optional_file.sh ├── build_basic_md5_with_optional_file_broken.errsh ├── build_cal_add_days.sh ├── build_cal_add_sub_days.sh ├── build_cal_append.sh ├── build_cal_append_broken.errsh ├── cal.cmd ├── cal_add_days.ml ├── cal_add_interactive.ml ├── cal_add_labels.ml ├── cal_add_sub_days.ml ├── cal_append.ml ├── cal_append_broken.ml ├── cal_completion.rawsh ├── command_types.topscript ├── get_basic_md5_help.errsh ├── get_basic_md5_version.sh ├── group.topscript ├── md5_completion.sh ├── opam.rawsh ├── run_basic_and_default_md5.sh ├── run_basic_md5.sh ├── run_basic_md5_as_filename.errsh ├── run_basic_md5_flags_help.sh ├── run_basic_md5_with_custom_arg.errsh ├── run_cal_add_sub_days.sh ├── single_anon_filename.topscript └── step.topscript ├── corebuild ├── ctypes ├── ctypes.mli └── ctypes_impl.ml ├── error-handling ├── blow_up.ml ├── build_blow_up.errsh ├── build_blow_up_notrace.errsh ├── exn_cost.ml ├── main.topscript ├── result.ml ├── result.mli ├── run_exn_cost.sh ├── run_exn_cost_notrace.sh ├── sexpr.scm └── try_with.syntax ├── exec_script.sh ├── exec_topscript.sh ├── fcm ├── build_query_handler.sh ├── build_query_handler_loader.sh ├── fcm.syntax ├── loader_cli1.rawsh ├── loader_cli2.rawsh ├── loader_cli3.rawsh ├── loader_cli4.rawsh ├── main.topscript ├── pack.syntax ├── query-syntax.scm ├── query_example.rawscript ├── query_handler.ml ├── query_handler.topscript ├── query_handler_core.ml ├── query_handler_loader.ml └── unpack.syntax ├── ffi ├── build_datetime.sh ├── build_hello.sh ├── build_qsort.sh ├── datetime.ml ├── hello.ml ├── infer_ncurses.sh ├── input.txt ├── install.rawsh ├── ncurses.h ├── ncurses.inferred.mli ├── ncurses.ml ├── ncurses.mli ├── posix.topscript ├── posix_headers.h ├── qsort.h ├── qsort.ml ├── qsort.mli ├── qsort.topscript ├── qsort_typedef.h ├── return_c_frag.c ├── return_c_frag.h ├── return_c_uncurried.c ├── return_frag.ml └── timeval_headers.h ├── files-modules-and-programs-freq-cyclic1 ├── build.errsh ├── counter.ml ├── counter.mli └── freq.ml ├── files-modules-and-programs-freq-cyclic2 ├── build.errsh ├── counter.ml ├── counter.mli └── freq.ml ├── files-modules-and-programs-freq-fast ├── build.sh ├── counter.ml ├── counter.mli └── freq.ml ├── files-modules-and-programs-freq-median ├── build.sh ├── build_use_median.sh ├── counter.ml ├── counter.mli ├── freq.ml ├── use_median_1.ml └── use_median_2.ml ├── files-modules-and-programs-freq-obuild ├── build.sh ├── freq.ml └── test.sh ├── files-modules-and-programs-freq-with-counter ├── build.sh ├── counter.ml ├── freq.ml └── infer_mli.sh ├── files-modules-and-programs-freq-with-missing-def ├── build.errsh ├── counter.ml ├── counter.mli └── freq.ml ├── files-modules-and-programs-freq-with-sig-abstract-fixed ├── build.sh ├── counter.ml ├── counter.mli └── freq.ml ├── files-modules-and-programs-freq-with-sig-abstract ├── build.errsh ├── counter.ml ├── counter.mli └── freq.ml ├── files-modules-and-programs-freq-with-sig-mismatch ├── build.errsh ├── counter.ml ├── counter.mli └── freq.ml ├── files-modules-and-programs-freq-with-sig ├── build.sh ├── counter.ml ├── counter.mli └── freq.ml ├── files-modules-and-programs-freq-with-type-mismatch ├── build.errsh ├── counter.ml ├── counter.mli └── freq.ml ├── files-modules-and-programs-freq ├── freq.ml ├── simple_build.sh └── simple_build_fail.errsh ├── files-modules-and-programs ├── abstract_username.ml ├── build_session_info.errsh ├── common.ml ├── confusing_username_and_host.ml ├── ext_list.ml ├── ext_list.mli ├── freq.ml ├── intro.topscript ├── main.topscript ├── module.syntax ├── session_info.ml └── val.syntax ├── front-end ├── alice.ml ├── alice.mli ├── alice_combined.ml ├── broken_module.ml ├── broken_poly.ml ├── broken_poly_with_annot.ml ├── build_broken_module.errsh ├── build_broken_poly.errsh ├── build_broken_poly_with_annot.errsh ├── build_follow_on_function.errsh ├── build_non_principal.sh ├── build_ocamldoc.rawsh ├── build_principal.sh ├── build_type_conv_with_camlp4.rawsh ├── build_type_conv_without_camlp4.errsh ├── camlp4_dump.cmd ├── camlp4_toplevel.topscript ├── comparelib_test.ml ├── comparelib_test.mli ├── conflicting_interfaces.errsh ├── doc.ml ├── fixed_module.ml ├── follow_on_function.ml ├── follow_on_function_fixed.ml ├── html │ ├── Doc.html │ ├── index.html │ ├── index_attributes.html │ ├── index_class_types.html │ ├── index_classes.html │ ├── index_exceptions.html │ ├── index_methods.html │ ├── index_module_types.html │ ├── index_modules.html │ ├── index_types.html │ ├── index_values.html │ ├── style.css │ └── type_Doc.html ├── inconsistent_compilation_units.rawsh ├── indent_follow_on_function.sh ├── indent_follow_on_function_fixed.sh ├── infer_typedef.sh ├── install_ocp_index.rawsh ├── let_notunit.ml ├── let_unit.syntax ├── man │ └── man3 │ │ ├── Doc.3o │ │ ├── My_exception.3o │ │ ├── Rain.3o │ │ ├── Sun.3o │ │ ├── weather.3o │ │ └── what_is_the_weather_in.3o ├── non_principal.ml ├── parsetree_typedef.sh ├── pipeline.ascii ├── principal.ml ├── process_comparelib_interface.sh ├── process_comparelib_test.sh ├── short_paths_1.rawsh ├── short_paths_2.rawsh ├── short_paths_3.rawsh ├── test.ml ├── test.mli ├── type_conv_example.ml ├── typedef.ml ├── typedef_objinfo.sh ├── typedtree_typedef.sh ├── unused_var.ml └── xbuild_type_conv_with_camlp4.sh ├── functors ├── build_extended_fqueue.sh ├── build_fqueue.sh ├── compare_example.ml ├── destructive_sub.syntax ├── extended_fqueue.ml ├── extended_fqueue.mli ├── foldable.ml ├── fqueue.ml ├── fqueue.mli ├── main-15.rawscript ├── main-18.rawscript ├── main-21.rawscript ├── main-25.rawscript ├── main.topscript ├── multi_sharing_constraint.syntax ├── sexpable.ml └── sharing_constraint.syntax ├── gc ├── barrier_bench.ml ├── finalizer.ml ├── minor_heap.ascii ├── run_barrier_bench.sh ├── run_finalizer.sh ├── show_barrier_bench_help.sh └── tune.topscript ├── guided-tour ├── build_sum.sh ├── local_let.topscript ├── main.topscript ├── recursion.ml ├── run_sum.sh ├── sum.ml └── sum.rawsh ├── imperative-programming ├── .gitignore ├── array-get.syntax ├── array-set.syntax ├── bigarray.syntax ├── build_all.sh ├── dictionary.ml ├── dictionary.mli ├── dictionary2.ml ├── dlist.ml ├── dlist.mli ├── edit_distance.ascii ├── edit_distance2.ascii ├── examples.topscript ├── fib.topscript ├── file.topscript ├── file2.topscript ├── for.topscript ├── lazy.topscript ├── let-unit.syntax ├── let_rec.ml ├── letrec.topscript ├── memo.topscript ├── order.topscript ├── printf.topscript ├── ref.topscript ├── remember_type.ml ├── semicolon-syntax.syntax ├── semicolon.syntax ├── string.syntax ├── time_converter.ml ├── time_converter.rawsh ├── time_converter2.ml ├── time_converter2.rawsh ├── value_restriction-13.rawscript ├── value_restriction.topscript └── weak.topscript ├── installation ├── arch_install.rawsh ├── arch_opam.rawsh ├── brew_install.rawsh ├── brew_opam_install.rawsh ├── debian_apt.rawsh ├── debian_apt_opam.rawsh ├── emacsrc.scm ├── fedora_install.rawsh ├── macports_install.rawsh ├── macports_opam_install.rawsh ├── ocaml_src_install.rawsh ├── ocaml_user_conf.rawsh ├── opam_eval.rawsh ├── opam_init.rawsh ├── opam_install.rawsh ├── opam_install_utop.rawsh ├── opam_list.rawsh ├── opam_switch.rawsh ├── open_core.ml ├── show_ocamlinit.rawsh └── ubuntu_opam_ppa.rawsh ├── json ├── _tags ├── book.json ├── build_github_atd.sh ├── build_github_org.sh ├── build_json.topscript ├── generate_github_org_json.sh ├── generate_github_org_types.sh ├── github.atd ├── github_j.ml ├── github_j.mli ├── github_j_excerpt.mli ├── github_org.atd ├── github_org_info.ml ├── github_org_j.ml ├── github_org_j.mli ├── github_org_t.ml ├── github_org_t.mli ├── github_t.ml ├── github_t.mli ├── install.topscript ├── install_atdgen.rawsh ├── list_excerpt.mli ├── parse_book.ml ├── parse_book.topscript ├── read_json.ml ├── run_github_org.sh ├── run_parse_book.sh ├── run_read_json.sh ├── yojson_basic.mli ├── yojson_basic_simple.mli └── yojson_safe.mli ├── lists-and-patterns ├── example.ml ├── example.mli ├── lists_layout.ascii └── main.topscript ├── maps-and-hash-tables ├── comparable.ml ├── core_phys_equal.topscript ├── main-22.rawscript ├── main-23.rawscript ├── main-24.rawscript ├── main-30.rawscript ├── main.topscript ├── map_vs_hash.ml ├── map_vs_hash2.ml ├── phys_equal.rawscript ├── run_map_vs_hash.sh └── run_map_vs_hash2.sh ├── memory-repr ├── block.ascii ├── custom_ops.c ├── float_array_layout.ascii ├── reprs.topscript ├── simple_record.topscript ├── string_block.ascii ├── string_size_calc.ascii └── tuple_layout.ascii ├── objects ├── IsBarbell.java ├── Shape.java ├── immutable.topscript ├── is_barbell.ml ├── narrowing.ml ├── polymorphism.topscript ├── row_polymorphism.topscript ├── stack.topscript ├── subtyping.ml └── subtyping.topscript ├── ocp-index ├── index_ncurses.sh ├── ncurses.ml └── ncurses.mli ├── packing ├── A.ml ├── B.ml ├── X.mlpack ├── _tags ├── build_test.sh ├── show_files.sh └── test.ml ├── parsing-test ├── build_json_parser.sh ├── build_test.sh ├── json.ml ├── lexer.mll ├── parser.mly ├── run_broken_test.errsh ├── short_parser.mly ├── test.ml ├── test1.json └── test2.json ├── parsing ├── basic_parser.mly ├── build_short_parser.sh ├── example.json ├── json.ml ├── lex.syntax ├── lexer.mll ├── lexer_int_fragment.mll ├── manual_token_type.ml ├── parsed_example.ml ├── parser.mly ├── production.syntax ├── prog.mli ├── quadratic_rule.mly ├── right_rec_rule.mly ├── short_parser.mly ├── tokenized_example.ml ├── tokens.ml └── yacc.syntax ├── principal ├── build_principal.sh ├── non_principal.ml └── principal.ml ├── records ├── functional_update.syntax ├── main-29.rawscript ├── main.topscript ├── record.syntax └── warn_help.sh ├── sexpr ├── auto_making_sexp.topscript ├── basic.scm ├── build_read_foo.errsh ├── build_read_foo_better_errors.errsh ├── build_test_interval.sh ├── build_test_interval_manual_sexp.sh ├── build_test_interval_nosexp.errsh ├── comment_heavy.scm ├── example.scm ├── example_broken.scm ├── example_load.topscript ├── foo_broken_example.scm ├── inline_sexp.topscript ├── int_interval.ml ├── int_interval.mli ├── int_interval_manual_sexp.ml ├── int_interval_manual_sexp.mli ├── int_interval_nosexp.ml ├── int_interval_nosexp.mli ├── list_top_packages.sh ├── manually_making_sexp.topscript ├── print_sexp.topscript ├── read_foo.ml ├── read_foo_better_errors.ml ├── sexp.mli ├── sexp_default.topscript ├── sexp_list.topscript ├── sexp_opaque.topscript ├── sexp_option.topscript ├── sexp_override.ml ├── sexp_printer.topscript ├── test_interval.ml ├── test_interval_manual_sexp.ml ├── test_interval_nosexp.ml └── to_from_sexp.topscript ├── variables-and-functions ├── abs_diff.mli ├── htable_sig1.ml ├── htable_sig2.ml ├── let.syntax ├── let_in.syntax ├── main.topscript ├── numerical_deriv_alt_sig.mli ├── operators.syntax ├── substring_sig1.ml └── substring_sig2.ml ├── variants-termcol-annotated ├── build.errsh ├── terminal_color.ml └── terminal_color.mli ├── variants-termcol-fixed ├── build.sh ├── terminal_color.ml └── terminal_color.mli ├── variants-termcol ├── build.sh ├── terminal_color.ml └── terminal_color.mli └── variants ├── blang.topscript ├── catch_all.topscript ├── logger.topscript ├── main-2.rawscript ├── main-5.rawscript ├── main.topscript └── variant.syntax /.gitignore: -------------------------------------------------------------------------------- 1 | *.out 2 | *.out.full 3 | *.a 4 | a.out 5 | .*.swp 6 | *.aux 7 | *.aux 8 | *.byte 9 | *.cmo 10 | *.cmi 11 | *.cmx 12 | *.cmxa 13 | *.cma 14 | *.idx 15 | *.log 16 | *.native 17 | *.byte 18 | *.o 19 | *.omakedb.lock 20 | *.omc 21 | *.tmp 22 | *.toc 23 | *~ 24 | .*.swp 25 | .DS_Store 26 | .bzr 27 | .bzrignore 28 | .project 29 | .pydevproject 30 | .settings 31 | /commenting-build 32 | _build 33 | -------------------------------------------------------------------------------- /INSTALL.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | opam install -j 4 --yes \ 4 | core \ 5 | core_extended \ 6 | cryptokit \ 7 | core_bench \ 8 | atdgen \ 9 | async \ 10 | yojson \ 11 | textwrap \ 12 | cohttp \ 13 | async_graphics \ 14 | menhir \ 15 | utop \ 16 | cmdliner \ 17 | cow \ 18 | ocp-indent \ 19 | ctypes \ 20 | ocp-index 21 | 22 | echo You also need Pygments installed. 23 | echo This is python-pygments in Debian 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all depend clean distclean 2 | 3 | all: 4 | cd code && $(MAKE) -j1 5 | 6 | depend: 7 | ./INSTALL.sh 8 | 9 | clean: 10 | rm -rf scripts/_build 11 | cd code && $(MAKE) clean 12 | 13 | distclean: clean 14 | cd code && $(MAKE) distclean 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This repository contains all the code samples from Real World OCaml. The 2 | repository tags represent a particular release of the book. 3 | -------------------------------------------------------------------------------- /code/async/#build_other_searches.sh#: -------------------------------------------------------------------------------- 1 | corebuild -pkg cohttp.async,yojson,textwrap search_out_of_order.native 2 | 3 | -------------------------------------------------------------------------------- /code/async/better_echo.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | 4 | let run ~uppercase ~port = 5 | let host_and_port = 6 | Tcp.Server.create 7 | ~on_handler_error:`Raise 8 | (Tcp.on_port port) 9 | (fun _addr r w -> 10 | Pipe.transfer (Reader.pipe r) (Writer.pipe w) 11 | ~f:(if uppercase then String.uppercase else Fn.id)) 12 | in 13 | ignore (host_and_port : (Socket.Address.Inet.t, int) Tcp.Server.t Deferred.t); 14 | Deferred.never () 15 | 16 | let () = 17 | Command.async_basic 18 | ~summary:"Start an echo server" 19 | Command.Spec.( 20 | empty 21 | +> flag "-uppercase" no_arg 22 | ~doc:" Convert to uppercase before echoing back" 23 | +> flag "-port" (optional_with_default 8765 int) 24 | ~doc:" Port to listen on (default 8765)" 25 | ) 26 | (fun uppercase port () -> run ~uppercase ~port) 27 | |> Command.run 28 | -------------------------------------------------------------------------------- /code/async/build_echo.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg async echo.native 2 | corebuild -pkg async better_echo.native 3 | -------------------------------------------------------------------------------- /code/async/build_other_searches.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cohttp.async,yojson,textwrap search_out_of_order.native 2 | 3 | -------------------------------------------------------------------------------- /code/async/echo.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | 4 | (* Copy data from the reader to the writer, using the provided buffer 5 | as scratch space *) 6 | let rec copy_blocks buffer r w = 7 | Reader.read r buffer 8 | >>= function 9 | | `Eof -> return () 10 | | `Ok bytes_read -> 11 | Writer.write w buffer ~len:bytes_read; 12 | Writer.flushed w 13 | >>= fun () -> 14 | copy_blocks buffer r w 15 | 16 | (* part 1 *) 17 | (** Starts a TCP server, which listens on the specified port, invoking 18 | copy_blocks every time a client connects. *) 19 | let run () = 20 | let host_and_port = 21 | Tcp.Server.create 22 | ~on_handler_error:`Raise 23 | (Tcp.on_port 8765) 24 | (fun _addr r w -> 25 | let buffer = String.create (16 * 1024) in 26 | copy_blocks buffer r w) 27 | in 28 | ignore (host_and_port : (Socket.Address.Inet.t, int) Tcp.Server.t Deferred.t) 29 | 30 | (* part 2 *) 31 | (* Call [run], and then start the scheduler *) 32 | let () = 33 | run (); 34 | never_returns (Scheduler.go ()) 35 | -------------------------------------------------------------------------------- /code/async/main-35.rawscript: -------------------------------------------------------------------------------- 1 | # let swallow_error () = 2 | let monitor = Monitor.create () in 3 | Stream.iter (Monitor.errors monitor) ~f:(fun _exn -> 4 | printf "an error happened\n"); 5 | within' ~monitor (fun () -> 6 | after (Time.Span.of_sec 0.5) >>= fun () -> failwith "Kaboom!") 7 | ;; 8 | val swallow_error : unit -> 'a Deferred.t = 9 | # swallow_error ();; 10 | an error happened 11 | 12 | -------------------------------------------------------------------------------- /code/async/main-38.rawscript: -------------------------------------------------------------------------------- 1 | # swallow_some_errors Ignore_me;; 2 | ignoring exn 3 | -------------------------------------------------------------------------------- /code/async/main-44.rawscript: -------------------------------------------------------------------------------- 1 | # log_delays (fun () -> after (sec 0.5));; 2 | 0.154972ms, 102.126ms, 203.658ms, 305.73ms, 407.903ms, 501.563ms, 3 | - : unit = () 4 | -------------------------------------------------------------------------------- /code/async/main-45.rawscript: -------------------------------------------------------------------------------- 1 | # let busy_loop n = 2 | let x = ref None in 3 | for i = 1 to 100_000_000 do x := Some i done 4 | ;; 5 | val busy_loop : 'a -> unit = 6 | # log_delays (fun () -> return (busy_loop ()));; 7 | 19.2185s, 8 | - : unit = () 9 | -------------------------------------------------------------------------------- /code/async/main-46.rawscript: -------------------------------------------------------------------------------- 1 | # log_delays (fun () -> In_thread.run busy_loop);; 2 | 0.332117ms, 16.6319s, 18.8722s, 3 | - : unit = () 4 | -------------------------------------------------------------------------------- /code/async/main-47.rawscript: -------------------------------------------------------------------------------- 1 | # let noalloc_busy_loop () = 2 | for i = 0 to 100_000_000 do () done 3 | ;; 4 | val noalloc_busy_loop : unit -> unit = 5 | # log_delays (fun () -> In_thread.run noalloc_busy_loop);; 6 | 0.169039ms, 4.58345s, 4.77866s, 4.87957s, 12.4723s, 15.0134s, 7 | - : unit = () 8 | -------------------------------------------------------------------------------- /code/async/native_code_log_delays.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | 4 | let log_delays thunk = 5 | let start = Time.now () in 6 | let print_time () = 7 | let diff = Time.diff (Time.now ()) start in 8 | printf "%s, " (Time.Span.to_string diff) 9 | in 10 | let d = thunk () in 11 | Clock.every (sec 0.1) ~stop:d print_time; 12 | d >>| fun () -> print_time (); printf "\n" 13 | 14 | let noalloc_busyloop () = 15 | for _i = 1 to 25_000_000_000 do () done; 16 | Deferred.unit 17 | 18 | let () = 19 | Command.async_basic 20 | ~summary:"run logger without busy loop" 21 | Command.Spec.(empty) 22 | (fun () -> log_delays noalloc_busyloop) 23 | |> Command.run 24 | -------------------------------------------------------------------------------- /code/async/pipe_write_break.rawscript: -------------------------------------------------------------------------------- 1 | # Pipe.write w "Hello World!";; 2 | Interrupted. 3 | -------------------------------------------------------------------------------- /code/async/pipe_write_break.rawtopscript: -------------------------------------------------------------------------------- 1 | # Pipe.write w "Hello World!";; 2 | Interrupted. 3 | -------------------------------------------------------------------------------- /code/async/run_echo.rawsh: -------------------------------------------------------------------------------- 1 | $ ./echo.native & 2 | $ nc 127.0.0.1 8765 3 | This is an echo server 4 | This is an echo server 5 | It repeats whatever I write. 6 | It repeats whatever I write. 7 | -------------------------------------------------------------------------------- /code/async/run_native_code_log_delays.rawsh: -------------------------------------------------------------------------------- 1 | $ corebuild -pkg async native_code_log_delays.native 2 | $ ./native_code_log_delays.native 3 | 15.5686s, 4 | $ 5 | -------------------------------------------------------------------------------- /code/async/run_native_code_log_delays_orig.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg async native_code_log_delays.native 2 | ./native_code_log_delays.native 3 | 4 | -------------------------------------------------------------------------------- /code/async/run_search.rawsh: -------------------------------------------------------------------------------- 1 | $ corebuild -pkg cohttp.async,yojson,textwrap search.native 2 | $ ./search.native "Concurrent Programming" "OCaml" 3 | Concurrent Programming 4 | ---------------------- 5 | 6 | "Concurrent computing is a form of computing in which programs are 7 | designed as collections of interacting computational processes that 8 | may be executed in parallel." 9 | 10 | OCaml 11 | ----- 12 | 13 | "OCaml, originally known as Objective Caml, is the main implementation 14 | of the Caml programming language, created by Xavier Leroy, Jérôme 15 | Vouillon, Damien Doligez, Didier Rémy and others in 1996." 16 | 17 | -------------------------------------------------------------------------------- /code/async/run_search_orig.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cohttp.async,yojson,textwrap search.native 2 | ./search.native "Concurrent Programming" "OCaml" 3 | -------------------------------------------------------------------------------- /code/async/run_search_with_configurable_server.rawsh: -------------------------------------------------------------------------------- 1 | $ corebuild -pkg cohttp.async,yojson,textwrap \ 2 | search_with_configurable_server.native 3 | $ ./search_with_configurable_server.native \ 4 | -servers localhost,api.duckduckgo.com \ 5 | "Concurrent Programming" OCaml 6 | ("unhandled exception" 7 | ((lib/monitor.ml.Error_ 8 | ((exn (Unix.Unix_error "Connection refused" connect 127.0.0.1:80)) 9 | (backtrace 10 | ("Raised by primitive operation at file \"lib/unix_syscalls.ml\", line 797, characters 12-69" 11 | "Called from file \"lib/deferred.ml\", line 20, characters 62-65" 12 | "Called from file \"lib/scheduler.ml\", line 125, characters 6-17" 13 | "Called from file \"lib/jobs.ml\", line 65, characters 8-13" "")) 14 | (monitor 15 | (((name Tcp.close_sock_on_error) (here ()) (id 5) (has_seen_error true) 16 | (someone_is_listening true) (kill_index 0)) 17 | ((name main) (here ()) (id 1) (has_seen_error true) 18 | (someone_is_listening false) (kill_index 0)))))) 19 | (Pid 15971))) 20 | -------------------------------------------------------------------------------- /code/async/run_search_with_configurable_server_orig.errsh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cohttp.async,yojson,textwrap search_with_configurable_server.native 2 | ./search_with_configurable_server.native -servers localhost,api.duckduckgo.com "Concurrent Programming" OCaml 3 | -------------------------------------------------------------------------------- /code/async/run_search_with_error_handling.rawsh: -------------------------------------------------------------------------------- 1 | $ corebuild -pkg cohttp.async,yojson,textwrap \ 2 | search_with_error_handling.native 3 | $ ./search_with_error_handling.native \ 4 | -servers localhost,api.duckduckgo.com \ 5 | "Concurrent Programming" OCaml 6 | Concurrent Programming 7 | ---------------------- 8 | 9 | DuckDuckGo query failed: Unexpected failure 10 | 11 | OCaml 12 | ----- 13 | 14 | "OCaml, originally known as Objective Caml, is the main implementation 15 | of the Caml programming language, created by Xavier Leroy, Jérôme 16 | Vouillon, Damien Doligez, Didier Rémy and others in 1996." 17 | 18 | -------------------------------------------------------------------------------- /code/async/run_search_with_error_handling_orig.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cohttp.async,yojson,textwrap search_with_error_handling.native 2 | ./search_with_error_handling.native -servers localhost,api.duckduckgo.com "Concurrent Programming" OCaml 3 | -------------------------------------------------------------------------------- /code/async/run_search_with_timeout_no_leak.rawsh: -------------------------------------------------------------------------------- 1 | $ corebuild -pkg cohttp.async,yojson,textwrap \ 2 | search_with_timeout_no_leak.native 3 | $ ./search_with_timeout_no_leak.native \ 4 | "concurrent programming" ocaml -timeout 0.2s 5 | concurrent programming 6 | ---------------------- 7 | 8 | DuckDuckGo query failed: Timed out 9 | 10 | ocaml 11 | ----- 12 | 13 | "OCaml or Objective Caml, is the main implementation of the Caml 14 | programming language, created by Xavier Leroy, Jérôme Vouillon, 15 | Damien Doligez, Didier Rémy and others in 1996." 16 | -------------------------------------------------------------------------------- /code/async/run_search_with_timeout_no_leak_orig.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cohttp.async,yojson,textwrap search_with_timeout_no_leak.native 2 | ./search_with_timeout_no_leak.native "concurrent programming" ocaml -timeout 0.2s 3 | -------------------------------------------------------------------------------- /code/async/run_thread.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg async thread_exp_async_only.native 2 | ./thread_exp_async_only.native 3 | -------------------------------------------------------------------------------- /code/async/test.txt: -------------------------------------------------------------------------------- 1 | This is only a test. -------------------------------------------------------------------------------- /code/async/thread_exp_async_busy_loop.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | open Thread_exp_common 4 | 5 | 6 | (* part 1 *) 7 | let busy_loop n = 8 | let x = ref None in 9 | for i = 1 to 100_000_000 do x := Some i done 10 | 11 | let () = 12 | don't_wait_for 13 | (log_delays (Deferred.unit >>= busy_loop)) 14 | 15 | (* part 2 *) 16 | let () = finish () 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /code/async/thread_exp_async_busy_loop_in_thread.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | open Thread_exp_common 4 | 5 | 6 | (* part 1 *) 7 | let busy_loop n = 8 | let x = ref None in 9 | for i = 1 to 100_000_000 do x := Some i done 10 | 11 | let () = 12 | don't_wait_for 13 | (log_delays (In_thread.run busy_loop)) 14 | 15 | (* part 2 *) 16 | let () = finish () 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /code/async/thread_exp_async_noalloc_busy_loop.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | open Thread_exp_common 4 | 5 | 6 | (* part 1 *) 7 | let busy_loop () = 8 | for i = 1 to 200_000_000 do () done 9 | 10 | let () = 11 | don't_wait_for 12 | (log_delays (In_thread.run busy_loop)) 13 | 14 | (* part 2 *) 15 | let () = finish () 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /code/async/thread_exp_async_noalloc_busy_loop_in_thread.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | open Thread_exp_common 4 | 5 | 6 | (* part 1 *) 7 | let busy_loop () = 8 | for i = 1 to 200_000_000 do () done 9 | 10 | let () = 11 | don't_wait_for 12 | (log_delays (In_thread.run busy_loop)) 13 | 14 | (* part 2 *) 15 | let () = finish () 16 | 17 | 18 | 19 | -------------------------------------------------------------------------------- /code/async/thread_exp_async_only.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | open Thread_exp_common 4 | 5 | let () = 6 | Command.async_basic 7 | ~summary:"run logger without busy loop" 8 | Command.Spec.(empty) 9 | (fun () -> 10 | log_delays (after (sec 1.)) 11 | ) 12 | |> Command.run 13 | -------------------------------------------------------------------------------- /code/async/thread_exp_common.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Async.Std 3 | 4 | let log_delays d = 5 | let start = Time.now () in 6 | let rec loop stamps = 7 | let delay = Time.diff (Time.now ()) start in 8 | match Deferred.peek d with 9 | | Some () -> return (delay :: stamps) 10 | | None -> 11 | after (sec 0.1) 12 | >>= fun () -> 13 | loop (delay :: stamps) 14 | in 15 | loop [] 16 | >>| fun delays -> 17 | let sexp = <:sexp_of> (List.rev delays) in 18 | printf "%s\n" (Sexp.to_string sexp) 19 | 20 | let finish () = 21 | shutdown 0; 22 | never_returns (Scheduler.go ()) 23 | -------------------------------------------------------------------------------- /code/back-end-bench/alternate_list.ml: -------------------------------------------------------------------------------- 1 | ../back-end/alternate_list.ml -------------------------------------------------------------------------------- /code/back-end-bench/bench_poly_and_mono.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Core_bench.Std 3 | 4 | let polymorphic_compare () = 5 | let cmp a b = if a > b then a else b in 6 | for i = 0 to 1000 do 7 | ignore(cmp 0 i) 8 | done 9 | 10 | let monomorphic_compare () = 11 | let cmp (a:int) (b:int) = 12 | if a > b then a else b in 13 | for i = 0 to 1000 do 14 | ignore(cmp 0 i) 15 | done 16 | 17 | let tests = 18 | [ "Polymorphic comparison", polymorphic_compare; 19 | "Monomorphic comparison", monomorphic_compare ] 20 | 21 | let () = 22 | List.map tests ~f:(fun (name,test) -> Bench.Test.create ~name test) 23 | |> Bench.make_command 24 | |> Command.run 25 | -------------------------------------------------------------------------------- /code/back-end-bench/run_alternate_list.sh: -------------------------------------------------------------------------------- 1 | corebuild -tag debug alternate_list.native 2 | ./alternate_list.native -ascii 3 | -------------------------------------------------------------------------------- /code/back-end-bench/run_bench_patterns.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg core_bench bench_patterns.native 2 | ./bench_patterns.native -ascii 3 | -------------------------------------------------------------------------------- /code/back-end-bench/run_bench_poly_and_mono.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg core_bench bench_poly_and_mono.native 2 | ./bench_poly_and_mono.native -ascii 3 | -------------------------------------------------------------------------------- /code/back-end-embed/build_embed.sh: -------------------------------------------------------------------------------- 1 | rm -f embed_out.c 2 | ocamlc -output-obj -o embed_out.o embed_me1.ml embed_me2.ml 3 | -------------------------------------------------------------------------------- /code/back-end-embed/build_embed_binary.rawsh: -------------------------------------------------------------------------------- 1 | $ gcc -fPIC -Wall -I`ocamlc -where` -L`ocamlc -where` -ltermcap -lm -ldl \ 2 | -o finalbc.native main.c embed_out.o -lcamlrun 3 | $ ./finalbc.native 4 | Before calling OCaml 5 | hello embedded world 1 6 | hello embedded world 2 7 | After calling OCaml 8 | -------------------------------------------------------------------------------- /code/back-end-embed/build_embed_c.sh: -------------------------------------------------------------------------------- 1 | ocamlc -output-obj -o embed_out.c embed_me1.ml embed_me2.ml 2 | -------------------------------------------------------------------------------- /code/back-end-embed/build_embed_native.rawsh: -------------------------------------------------------------------------------- 1 | $ ocamlopt -output-obj -o embed_native.o embed_me1.ml embed_me2.ml 2 | $ gcc -Wall -I `ocamlc -where` -o final.native embed_native.o main.c \ 3 | -L `ocamlc -where` -lasmrun -ltermcap -lm -ldl 4 | $ ./final.native 5 | Before calling OCaml 6 | hello embedded world 1 7 | hello embedded world 2 8 | After calling OCaml 9 | -------------------------------------------------------------------------------- /code/back-end-embed/embed_me1.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "hello embedded world 1" 2 | -------------------------------------------------------------------------------- /code/back-end-embed/embed_me2.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "hello embedded world 2" 2 | -------------------------------------------------------------------------------- /code/back-end-embed/hello.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "Hello OCaml World!" 2 | -------------------------------------------------------------------------------- /code/back-end-embed/link_custom.rawsh: -------------------------------------------------------------------------------- 1 | $ ocamlc -a -o mylib.cma -custom a.cmo b.cmo -cclib -lmylib 2 | -------------------------------------------------------------------------------- /code/back-end-embed/link_dllib.rawsh: -------------------------------------------------------------------------------- 1 | $ ocamlc -a -o mylib.cma a.cmo b.cmo -dllib -lmylib 2 | -------------------------------------------------------------------------------- /code/back-end-embed/main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | int 8 | main (int argc, char **argv) 9 | { 10 | printf("Before calling OCaml\n"); 11 | fflush(stdout); 12 | caml_startup (argv); 13 | printf("After calling OCaml\n"); 14 | return 0; 15 | } 16 | -------------------------------------------------------------------------------- /code/back-end-embed/run_debug_hello.sh: -------------------------------------------------------------------------------- 1 | ocamlopt -runtime-variant d -verbose -o hello.native hello.ml 2 | ./hello.native 3 | -------------------------------------------------------------------------------- /code/back-end-embed/xbuild_embed_binary.sh: -------------------------------------------------------------------------------- 1 | gcc -fPIC -Wall -I`ocamlc -where` -L`ocamlc -where` -ltermcap -lm -ldl -o finalbc.native main.c embed_out.o -lcamlrun 2 | ./finalbc.native 3 | -------------------------------------------------------------------------------- /code/back-end-embed/xbuild_embed_native.sh: -------------------------------------------------------------------------------- 1 | ocamlopt -output-obj -o embed_native.o embed_me1.ml embed_me2.ml 2 | gcc -Wall -I `ocamlc -where` -o final.native embed_native.o main.c -L `ocamlc -where` -lasmrun -ltermcap -lm -ldl 3 | ./final.native 4 | -------------------------------------------------------------------------------- /code/back-end/alternate_list.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let rec take = 4 | function 5 | |[] -> [] 6 | |hd::tl -> hd :: (skip tl) 7 | and skip = 8 | function 9 | |[] -> [] 10 | |_::tl -> take tl 11 | 12 | let () = 13 | take [1;2;3;4;5;6;7;8;9] 14 | |> List.map ~f:string_of_int 15 | |> String.concat ~sep:"," 16 | |> print_endline 17 | -------------------------------------------------------------------------------- /code/back-end/asm_from_compare_mono.sh: -------------------------------------------------------------------------------- 1 | ocamlopt -inline 20 -nodynlink -S compare_mono.ml 2 | -------------------------------------------------------------------------------- /code/back-end/barrier_bench.ml: -------------------------------------------------------------------------------- 1 | ../gc/barrier_bench.ml -------------------------------------------------------------------------------- /code/back-end/cmp.S: -------------------------------------------------------------------------------- 1 | _camlCompare_mono__cmp_1008: 2 | .cfi_startproc 3 | .L101: 4 | cmpq %rbx, %rax 5 | jle .L100 6 | ret 7 | .align 2 8 | .L100: 9 | movq %rbx, %rax 10 | ret 11 | .cfi_endproc 12 | -------------------------------------------------------------------------------- /code/back-end/compare_mono.ml: -------------------------------------------------------------------------------- 1 | let cmp (a:int) (b:int) = 2 | if a > b then a else b 3 | -------------------------------------------------------------------------------- /code/back-end/compare_poly.ml: -------------------------------------------------------------------------------- 1 | let cmp a b = 2 | if a > b then a else b 3 | -------------------------------------------------------------------------------- /code/back-end/compare_poly_asm.S: -------------------------------------------------------------------------------- 1 | _camlCompare_poly__cmp_1008: 2 | .cfi_startproc 3 | subq $24, %rsp 4 | .cfi_adjust_cfa_offset 24 5 | .L101: 6 | movq %rax, 8(%rsp) 7 | movq %rbx, 0(%rsp) 8 | movq %rax, %rdi 9 | movq %rbx, %rsi 10 | leaq _caml_greaterthan(%rip), %rax 11 | call _caml_c_call 12 | .L102: 13 | leaq _caml_young_ptr(%rip), %r11 14 | movq (%r11), %r15 15 | cmpq $1, %rax 16 | je .L100 17 | movq 8(%rsp), %rax 18 | addq $24, %rsp 19 | .cfi_adjust_cfa_offset -24 20 | ret 21 | .cfi_adjust_cfa_offset 24 22 | .align 2 23 | .L100: 24 | movq 0(%rsp), %rax 25 | addq $24, %rsp 26 | .cfi_adjust_cfa_offset -24 27 | ret 28 | .cfi_adjust_cfa_offset 24 29 | .cfi_endproc 30 | -------------------------------------------------------------------------------- /code/back-end/gdb_alternate0.rawsh: -------------------------------------------------------------------------------- 1 | $ gdb ./alternate_list.native 2 | GNU gdb (GDB) 7.4.1-debian 3 | Copyright (C) 2012 Free Software Foundation, Inc. 4 | License GPLv3+: GNU GPL version 3 or later 5 | This is free software: you are free to change and redistribute it. 6 | There is NO WARRANTY, to the extent permitted by law. Type "show copying" 7 | and "show warranty" for details. 8 | This GDB was configured as "x86_64-linux-gnu". 9 | For bug reporting instructions, please see: 10 | ... 11 | Reading symbols from /home/avsm/alternate_list.native...done. 12 | (gdb) 13 | -------------------------------------------------------------------------------- /code/back-end/gdb_alternate1.rawsh: -------------------------------------------------------------------------------- 1 | (gdb) break camlAlternate_list__take_69242 2 | Breakpoint 1 at 0x5658d0: file alternate_list.ml, line 5. 3 | -------------------------------------------------------------------------------- /code/back-end/gdb_alternate2.rawsh: -------------------------------------------------------------------------------- 1 | (gdb) run 2 | Starting program: /home/avsm/alternate_list.native 3 | [Thread debugging using libthread_db enabled] 4 | Using host libthread_db library "/lib/x86_64-linux-gnu/libthread_db.so.1". 5 | 6 | Breakpoint 1, camlAlternate_list__take_69242 () at alternate_list.ml:5 7 | 4 function 8 | -------------------------------------------------------------------------------- /code/back-end/gdb_alternate3.rawsh: -------------------------------------------------------------------------------- 1 | (gdb) cont 2 | Continuing. 3 | 4 | Breakpoint 1, camlAlternate_list__take_69242 () at alternate_list.ml:5 5 | 4 function 6 | (gdb) cont 7 | Continuing. 8 | 9 | Breakpoint 1, camlAlternate_list__take_69242 () at alternate_list.ml:5 10 | 4 function 11 | (gdb) bt 12 | #0 camlAlternate_list__take_69242 () at alternate_list.ml:4 13 | #1 0x00000000005658e7 in camlAlternate_list__take_69242 () at alternate_list.ml:6 14 | #2 0x00000000005658e7 in camlAlternate_list__take_69242 () at alternate_list.ml:6 15 | #3 0x00000000005659f7 in camlAlternate_list__entry () at alternate_list.ml:14 16 | #4 0x0000000000560029 in caml_program () 17 | #5 0x000000000080984a in caml_start_program () 18 | #6 0x00000000008099a0 in ?? () 19 | #7 0x0000000000000000 in ?? () 20 | (gdb) clear camlAlternate_list__take_69242 21 | Deleted breakpoint 1 22 | (gdb) cont 23 | Continuing. 24 | 1,3,5,7,9 25 | [Inferior 1 (process 3546) exited normally] 26 | -------------------------------------------------------------------------------- /code/back-end/instr_for_pattern_monomorphic_small.sh: -------------------------------------------------------------------------------- 1 | ocamlc -dinstr pattern_monomorphic_small.ml 2>&1 2 | -------------------------------------------------------------------------------- /code/back-end/lambda_for_pattern_monomorphic_large.sh: -------------------------------------------------------------------------------- 1 | ocamlc -dlambda -c pattern_monomorphic_large.ml 2>&1 2 | -------------------------------------------------------------------------------- /code/back-end/lambda_for_pattern_monomorphic_small.sh: -------------------------------------------------------------------------------- 1 | ocamlc -dlambda -c pattern_monomorphic_small.ml 2>&1 2 | -------------------------------------------------------------------------------- /code/back-end/lambda_for_pattern_polymorphic.sh: -------------------------------------------------------------------------------- 1 | ocamlc -dlambda -c pattern_polymorphic.ml 2>&1 2 | -------------------------------------------------------------------------------- /code/back-end/opam_switch.rawsh: -------------------------------------------------------------------------------- 1 | $ opam switch 4.01.0dev+fp 2 | -------------------------------------------------------------------------------- /code/back-end/pattern_monomorphic_large.ml: -------------------------------------------------------------------------------- 1 | type t = | Alice | Bob | Charlie | David 2 | 3 | let test v = 4 | match v with 5 | | Alice -> 100 6 | | Bob -> 101 7 | | Charlie -> 102 8 | | David -> 103 9 | -------------------------------------------------------------------------------- /code/back-end/pattern_monomorphic_small.ml: -------------------------------------------------------------------------------- 1 | type t = | Alice | Bob 2 | 3 | let test v = 4 | match v with 5 | | Alice -> 100 6 | | Bob -> 101 7 | -------------------------------------------------------------------------------- /code/back-end/pattern_polymorphic.ml: -------------------------------------------------------------------------------- 1 | let test v = 2 | match v with 3 | | `Alice -> 100 4 | | `Bob -> 101 5 | | `Charlie -> 102 6 | | `David -> 103 7 | | `Eve -> 104 8 | -------------------------------------------------------------------------------- /code/back-end/perf_record.rawsh: -------------------------------------------------------------------------------- 1 | $ perf record -g ./barrier_bench.native 2 | Estimated testing time 20s (change using -quota SECS). 3 | 4 | Name Time (ns) Time 95ci Percentage 5 | ---- --------- --------- ---------- 6 | mutable 7_306_219 7_250_234-7_372_469 96.83 7 | immutable 7_545_126 7_537_837-7_551_193 100.00 8 | 9 | [ perf record: Woken up 11 times to write data ] 10 | [ perf record: Captured and wrote 2.722 MB perf.data (~118926 samples) ] 11 | perf record -g ./barrier.native 12 | Estimated testing time 20s (change using -quota SECS). 13 | 14 | Name Time (ns) Time 95ci Percentage 15 | ---- --------- --------- ---------- 16 | mutable 7_306_219 7_250_234-7_372_469 96.83 17 | immutable 7_545_126 7_537_837-7_551_193 100.00 18 | 19 | [ perf record: Woken up 11 times to write data ] 20 | [ perf record: Captured and wrote 2.722 MB perf.data (~118926 samples) ] 21 | -------------------------------------------------------------------------------- /code/back-end/perf_report.rawsh: -------------------------------------------------------------------------------- 1 | $ perf report -g 2 | + 48.86% barrier.native barrier.native [.] camlBarrier__test_immutable_69282 3 | + 30.22% barrier.native barrier.native [.] camlBarrier__test_mutable_69279 4 | + 20.22% barrier.native barrier.native [.] caml_modify 5 | -------------------------------------------------------------------------------- /code/classes-async/build_shapes.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg async_graphics shapes.native 2 | -------------------------------------------------------------------------------- /code/classes/Iterator.java: -------------------------------------------------------------------------------- 1 | // Java-style iterator, specified as an interface. 2 | interface iterator { 3 | T Get(); 4 | boolean HasValue(); 5 | void Next(); 6 | }; 7 | -------------------------------------------------------------------------------- /code/classes/binary_larger.ml: -------------------------------------------------------------------------------- 1 | class square w = object(self) 2 | method width = w 3 | method area = Float.of_int (self#width * self#width) 4 | method larger other = self#area > other#area 5 | end 6 | -------------------------------------------------------------------------------- /code/classes/binary_module.ml: -------------------------------------------------------------------------------- 1 | module Shapes : sig 2 | type shape_repr 3 | type shape = 4 | < repr : shape_repr; equals : shape -> bool; area: float > 5 | 6 | class square : int -> 7 | object 8 | method width : int 9 | method area : float 10 | method repr : shape_repr 11 | method equals : shape -> bool 12 | end 13 | end = struct 14 | type shape_repr = 15 | | Square of int 16 | | Circle of int 17 | ... 18 | end 19 | -------------------------------------------------------------------------------- /code/classes/build_doc.sh: -------------------------------------------------------------------------------- 1 | corebuild doc.native 2 | -------------------------------------------------------------------------------- /code/classes/citerator.cpp: -------------------------------------------------------------------------------- 1 | // Abstract class definition in C++. 2 | template 3 | class Iterator { 4 | public: 5 | virtual ~Iterator() {} 6 | virtual T get() const = 0; 7 | virtual bool has_value() const = 0; 8 | virtual void next() = 0; 9 | }; 10 | -------------------------------------------------------------------------------- /code/classes/class_types_stack.ml: -------------------------------------------------------------------------------- 1 | module Stack = struct 2 | class ['a] stack init = object 3 | ... 4 | end 5 | 6 | type 'a t = 'a stack 7 | 8 | let make init = new stack init 9 | end 10 | 11 | (* part 1 *) 12 | module AbstractStack : sig 13 | type 'a t = < pop: 'a option; push: 'a -> unit > 14 | 15 | val make : unit -> 'a t 16 | end = Stack 17 | 18 | (* part 2 *) 19 | module VisibleStack : sig 20 | 21 | type 'a t = < pop: 'a option; push: 'a -> unit > 22 | 23 | class ['a] stack : object 24 | val mutable v : 'a list 25 | method pop : 'a option 26 | method push : 'a -> unit 27 | end 28 | 29 | val make : unit -> 'a t 30 | end = Stack 31 | -------------------------------------------------------------------------------- /code/classes/initializer.topscript: -------------------------------------------------------------------------------- 1 | class obj x = 2 | let () = printf "Creating obj %d\n" x in 3 | object 4 | val field = printf "Initializing field\n"; x 5 | end ;; 6 | let o = new obj 3 ;; 7 | -------------------------------------------------------------------------------- /code/classes/istack.topscript: -------------------------------------------------------------------------------- 1 | class istack = object 2 | val mutable v = [0; 2] 3 | 4 | method pop = 5 | match v with 6 | | hd :: tl -> 7 | v <- tl; 8 | Some hd 9 | | [] -> None 10 | 11 | method push hd = 12 | v <- hd :: v 13 | end ;; 14 | #part 1 15 | let s = new istack ;; 16 | s#pop ;; 17 | s#push 5 ;; 18 | s#pop ;; 19 | - : int option = Some 5 20 | #part 2 21 | type istack = < pop: int option; push: int -> unit > ;; 22 | -------------------------------------------------------------------------------- /code/classes/stack.topscript: -------------------------------------------------------------------------------- 1 | class ['a] stack init = object 2 | val mutable v : 'a list = init 3 | 4 | method pop = 5 | match v with 6 | | hd :: tl -> 7 | v <- tl; 8 | Some hd 9 | | [] -> None 10 | 11 | method push hd = 12 | v <- hd :: v 13 | end ;; 14 | #part 1 15 | class ['a] stack init = object 16 | val mutable v = init 17 | 18 | method pop = 19 | match v with 20 | | hd :: tl -> 21 | v <- tl; 22 | Some hd 23 | | [] -> None 24 | 25 | method push hd = 26 | v <- hd :: v 27 | end ;; 28 | #part 2 29 | class sstack init = object 30 | inherit [string] stack init 31 | 32 | method print = 33 | List.iter ~f:print_string v 34 | end ;; 35 | #part 3 36 | class double_stack init = object 37 | inherit [int] stack init as super 38 | 39 | method push hd = 40 | super#push (hd * 2) 41 | end ;; 42 | -------------------------------------------------------------------------------- /code/code: -------------------------------------------------------------------------------- 1 | examples/code -------------------------------------------------------------------------------- /code/command-line-parsing/_tags: -------------------------------------------------------------------------------- 1 | true: short_paths 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/basic.topscript: -------------------------------------------------------------------------------- 1 | Command.basic ;; 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/basic_md5.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let do_hash file = 4 | In_channel.with_file file ~f:(fun ic -> 5 | let open Cryptokit in 6 | hash_channel (Hash.md5 ()) ic 7 | |> transform_string (Hexa.encode ()) 8 | |> print_endline 9 | ) 10 | 11 | (* part 1 *) 12 | let spec = 13 | let open Command.Spec in 14 | empty 15 | +> anon ("filename" %: string) 16 | 17 | (* part 2 *) 18 | let command = 19 | Command.basic 20 | ~summary:"Generate an MD5 hash of the input data" 21 | ~readme:(fun () -> "More detailed information") 22 | spec 23 | (fun filename () -> do_hash filename) 24 | 25 | (* part 3 *) 26 | let () = 27 | Command.run ~version:"1.0" ~build_info:"RWO" command 28 | -------------------------------------------------------------------------------- /code/command-line-parsing/basic_md5_as_filename.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let do_hash file () = 4 | In_channel.with_file file ~f:( 5 | fun ic -> 6 | let open Cryptokit in 7 | hash_channel (Hash.md5 ()) ic 8 | |> transform_string (Hexa.encode ()) 9 | |> print_endline 10 | ) 11 | 12 | (* part 1 *) 13 | let command = 14 | Command.basic 15 | ~summary:"Generate an MD5 hash of the input data" 16 | ~readme:(fun () -> "More detailed information") 17 | Command.Spec.(empty +> anon ("filename" %: file)) 18 | do_hash 19 | 20 | let () = 21 | Command.run ~version:"1.0" ~build_info:"RWO" command 22 | -------------------------------------------------------------------------------- /code/command-line-parsing/basic_md5_sequence.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let do_hash filename ic = 4 | let open Cryptokit in 5 | hash_channel (Hash.md5 ()) ic 6 | |> transform_string (Hexa.encode ()) 7 | |> fun md5 -> printf "MD5 (%s) = %s\n" filename md5 8 | 9 | let command = 10 | Command.basic 11 | ~summary:"Generate an MD5 hash of the input data" 12 | ~readme:(fun () -> "More detailed information") 13 | Command.Spec.(empty +> anon (sequence ("filename" %: file))) 14 | (fun files () -> 15 | match files with 16 | | [] -> do_hash "-" In_channel.stdin 17 | | _ -> 18 | List.iter files ~f:(fun file -> 19 | In_channel.with_file ~f:(do_hash file) file 20 | ) 21 | ) 22 | 23 | let () = 24 | Command.run ~version:"1.0" ~build_info:"RWO" command 25 | -------------------------------------------------------------------------------- /code/command-line-parsing/basic_md5_succinct.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let do_hash file () = 4 | In_channel.with_file file ~f:(fun ic -> 5 | let open Cryptokit in 6 | hash_channel (Hash.md5 ()) ic 7 | |> transform_string (Hexa.encode ()) 8 | |> print_endline 9 | ) 10 | 11 | let command = 12 | Command.basic 13 | ~summary:"Generate an MD5 hash of the input data" 14 | ~readme:(fun () -> "More detailed information") 15 | Command.Spec.(empty +> anon ("filename" %: string)) 16 | do_hash 17 | 18 | let () = 19 | Command.run ~version:"1.0" ~build_info:"RWO" command 20 | -------------------------------------------------------------------------------- /code/command-line-parsing/basic_md5_with_custom_arg.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let do_hash file () = 4 | In_channel.with_file file ~f:(fun ic -> 5 | let open Cryptokit in 6 | hash_channel (Hash.md5 ()) ic 7 | |> transform_string (Hexa.encode ()) 8 | |> print_endline 9 | ) 10 | 11 | let regular_file = 12 | Command.Spec.Arg_type.create 13 | (fun filename -> 14 | match Sys.is_file filename with 15 | | `Yes -> filename 16 | | `No | `Unknown -> 17 | eprintf "'%s' is not a regular file.\n%!" filename; 18 | exit 1 19 | ) 20 | 21 | let command = 22 | Command.basic 23 | ~summary:"Generate an MD5 hash of the input data" 24 | ~readme:(fun () -> "More detailed information") 25 | Command.Spec.(empty +> anon ("filename" %: regular_file)) 26 | do_hash 27 | 28 | let () = 29 | Command.run ~version:"1.0" ~build_info:"RWO" command 30 | -------------------------------------------------------------------------------- /code/command-line-parsing/basic_md5_with_default_file.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let get_inchan = function 4 | | "-" -> In_channel.stdin 5 | | filename -> In_channel.create ~binary:true filename 6 | 7 | let do_hash filename () = 8 | let open Cryptokit in 9 | get_inchan filename 10 | |> hash_channel (Hash.md5 ()) 11 | |> transform_string (Hexa.encode ()) 12 | |> print_endline 13 | 14 | let command = 15 | Command.basic 16 | ~summary:"Generate an MD5 hash of the input data" 17 | ~readme:(fun () -> "More detailed information") 18 | Command.Spec.( 19 | empty 20 | +> anon (maybe_with_default "-" ("filename" %: file)) 21 | ) 22 | do_hash 23 | 24 | let () = 25 | Command.run ~version:"1.0" ~build_info:"RWO" command 26 | -------------------------------------------------------------------------------- /code/command-line-parsing/basic_md5_with_optional_file.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let get_inchan = function 4 | | None | Some "-" -> 5 | In_channel.stdin 6 | | Some filename -> 7 | In_channel.create ~binary:true filename 8 | 9 | let do_hash filename () = 10 | let open Cryptokit in 11 | get_inchan filename 12 | |> hash_channel (Hash.md5 ()) 13 | |> transform_string (Hexa.encode ()) 14 | |> print_endline 15 | 16 | let command = 17 | Command.basic 18 | ~summary:"Generate an MD5 hash of the input data" 19 | ~readme:(fun () -> "More detailed information") 20 | Command.Spec.(empty +> anon (maybe ("filename" %: file))) 21 | do_hash 22 | 23 | let () = 24 | Command.run ~version:"1.0" ~build_info:"RWO" command 25 | -------------------------------------------------------------------------------- /code/command-line-parsing/basic_md5_with_optional_file_broken.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let do_hash file () = 4 | In_channel.with_file file ~f:( 5 | fun ic -> 6 | let open Cryptokit in 7 | hash_channel (Hash.md5 ()) ic 8 | |> transform_string (Hexa.encode ()) 9 | |> print_endline 10 | ) 11 | 12 | (* part 1 *) 13 | let command = 14 | Command.basic 15 | ~summary:"Generate an MD5 hash of the input data" 16 | ~readme:(fun () -> "More detailed information") 17 | Command.Spec.(empty +> anon (maybe ("filename" %: string))) 18 | do_hash 19 | 20 | let () = 21 | Command.run ~version:"1.0" ~build_info:"RWO" command 22 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_and_run_cal_add_interactive.rawsh: -------------------------------------------------------------------------------- 1 | $ ocamlbuild -use-ocamlfind -tag thread -pkg core cal_add_interactive.native 2 | $ ./cal_add_interactive.native 2013-12-01 3 | enter days: 4 | 35 5 | 2014-01-05 6 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_basic_md5.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cryptokit basic_md5.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_basic_md5_as_filename.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cryptokit basic_md5_as_filename.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_basic_md5_sequence.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cryptokit basic_md5_sequence.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_basic_md5_with_custom_arg.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cryptokit basic_md5_with_custom_arg.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_basic_md5_with_default_file.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cryptokit basic_md5_with_default_file.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_basic_md5_with_flags.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cryptokit basic_md5_with_flags.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_basic_md5_with_opt_flags.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cryptokit basic_md5_with_opt_flags.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_basic_md5_with_optional_file.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cryptokit basic_md5_with_optional_file.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_basic_md5_with_optional_file_broken.errsh: -------------------------------------------------------------------------------- 1 | corebuild -pkg cryptokit basic_md5_with_optional_file_broken.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_cal_add_days.sh: -------------------------------------------------------------------------------- 1 | corebuild cal_add_days.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_cal_add_sub_days.sh: -------------------------------------------------------------------------------- 1 | corebuild cal_add_sub_days.native 2 | ./cal_add_sub_days.native -help 3 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_cal_append.sh: -------------------------------------------------------------------------------- 1 | corebuild cal_append.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/build_cal_append_broken.errsh: -------------------------------------------------------------------------------- 1 | corebuild cal_append_broken.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/cal.cmd: -------------------------------------------------------------------------------- 1 | function _jsautocom_96173 { 2 | export COMP_CWORD 3 | COMP_WORDS[0]=./cal_add_sub_days.native 4 | COMPREPLY=($("${COMP_WORDS[@]}")) 5 | } 6 | complete -F _jsautocom_96173 ./cal_add_sub_days.native 7 | -------------------------------------------------------------------------------- /code/command-line-parsing/cal_add_days.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let add = 4 | Command.basic 5 | ~summary:"Add [days] to the [base] date and print day" 6 | Command.Spec.( 7 | empty 8 | +> anon ("base" %: date) 9 | +> anon ("days" %: int) 10 | ) 11 | (fun base span () -> 12 | Date.add_days base span 13 | |> Date.to_string 14 | |> print_endline 15 | ) 16 | 17 | let () = Command.run add 18 | -------------------------------------------------------------------------------- /code/command-line-parsing/cal_add_interactive.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let add_days base span () = 4 | Date.add_days base span 5 | |> Date.to_string 6 | |> print_endline 7 | 8 | let add = 9 | Command.basic 10 | ~summary:"Add [days] to the [base] date and print day" 11 | Command.Spec.( 12 | step 13 | (fun m base days -> 14 | match days with 15 | | Some days -> 16 | m base days 17 | | None -> 18 | print_endline "enter days: "; 19 | read_int () 20 | |> m base 21 | ) 22 | +> anon ("base" %: date) 23 | +> anon (maybe ("days" %: int)) 24 | ) 25 | add_days 26 | 27 | let () = Command.run add 28 | -------------------------------------------------------------------------------- /code/command-line-parsing/cal_add_labels.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let add_days ~base_date ~num_days () = 4 | Date.add_days base_date num_days 5 | |> Date.to_string 6 | |> print_endline 7 | 8 | let add = 9 | Command.basic 10 | ~summary:"Add [days] to the [base] date and print day" 11 | Command.Spec.( 12 | step (fun m base days -> m ~base_date:base ~num_days:days) 13 | +> anon ("base" %: date) 14 | +> anon ("days" %: int) 15 | ) 16 | add_days 17 | 18 | let () = Command.run add 19 | -------------------------------------------------------------------------------- /code/command-line-parsing/cal_add_sub_days.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let add = 4 | Command.basic ~summary:"Add [days] to the [base] date" 5 | Command.Spec.( 6 | empty 7 | +> anon ("base" %: date) 8 | +> anon ("days" %: int) 9 | ) 10 | (fun base span () -> 11 | Date.add_days base span 12 | |> Date.to_string 13 | |> print_endline 14 | ) 15 | 16 | let diff = 17 | Command.basic ~summary:"Show days between [date1] and [date2]" 18 | Command.Spec.( 19 | empty 20 | +> anon ("date1" %: date) 21 | +> anon ("date2" %: date) 22 | ) 23 | (fun date1 date2 () -> 24 | Date.diff date1 date2 25 | |> printf "%d days\n" 26 | ) 27 | 28 | let command = 29 | Command.group ~summary:"Manipulate dates" 30 | [ "add", add; "diff", diff ] 31 | 32 | let () = Command.run command 33 | -------------------------------------------------------------------------------- /code/command-line-parsing/cal_completion.rawsh: -------------------------------------------------------------------------------- 1 | $ env COMMAND_OUTPUT_INSTALLATION_BASH=1 ./cal_add_sub_days.native > cal.cmd 2 | $ . cal.cmd 3 | $ ./cal_add_sub_days.native 4 | add diff help version 5 | -------------------------------------------------------------------------------- /code/command-line-parsing/command_types.topscript: -------------------------------------------------------------------------------- 1 | Command.Spec.empty ;; 2 | Command.Spec.(empty +> anon ("foo" %: int)) ;; 3 | -------------------------------------------------------------------------------- /code/command-line-parsing/get_basic_md5_help.errsh: -------------------------------------------------------------------------------- 1 | ./basic_md5.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/get_basic_md5_version.sh: -------------------------------------------------------------------------------- 1 | ./basic_md5.native -version 2 | ./basic_md5.native -build-info 3 | -------------------------------------------------------------------------------- /code/command-line-parsing/group.topscript: -------------------------------------------------------------------------------- 1 | Command.basic ;; 2 | Command.group ;; 3 | -------------------------------------------------------------------------------- /code/command-line-parsing/md5_completion.sh: -------------------------------------------------------------------------------- 1 | env COMMAND_OUTPUT_INSTALLATION_BASH=1 ./basic_md5_with_flags.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/opam.rawsh: -------------------------------------------------------------------------------- 1 | $ opam config env 2 | $ opam remote list -k git 3 | $ opam install --help 4 | $ opam install cryptokit --verbose 5 | -------------------------------------------------------------------------------- /code/command-line-parsing/run_basic_and_default_md5.sh: -------------------------------------------------------------------------------- 1 | cat /etc/passwd | ./basic_md5_with_optional_file.native 2 | cat /etc/passwd | ./basic_md5_with_default_file.native 3 | -------------------------------------------------------------------------------- /code/command-line-parsing/run_basic_md5.sh: -------------------------------------------------------------------------------- 1 | ./basic_md5.native ./basic_md5.native 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/run_basic_md5_as_filename.errsh: -------------------------------------------------------------------------------- 1 | ./basic_md5_as_filename.native nonexistent 2 | -------------------------------------------------------------------------------- /code/command-line-parsing/run_basic_md5_flags_help.sh: -------------------------------------------------------------------------------- 1 | ./basic_md5_with_flags.native -help 2 | ./basic_md5_with_flags.native -s "ocaml rocks" 3 | -------------------------------------------------------------------------------- /code/command-line-parsing/run_basic_md5_with_custom_arg.errsh: -------------------------------------------------------------------------------- 1 | ./basic_md5_with_custom_arg.native /etc/passwd 2 | ./basic_md5_with_custom_arg.native /dev/null 3 | -------------------------------------------------------------------------------- /code/command-line-parsing/run_cal_add_sub_days.sh: -------------------------------------------------------------------------------- 1 | ./cal_add_sub_days.native add 2012-12-25 40 2 | ./cal_add_sub_days.native diff 2012-12-25 2012-11-01 3 | -------------------------------------------------------------------------------- /code/command-line-parsing/single_anon_filename.topscript: -------------------------------------------------------------------------------- 1 | open Command.Spec ;; 2 | empty +> anon ("filename" %: string) ;; 3 | -------------------------------------------------------------------------------- /code/command-line-parsing/step.topscript: -------------------------------------------------------------------------------- 1 | open Command.Spec ;; 2 | step (fun m (base:Date.t) days -> 3 | match days with 4 | | Some days -> m base days 5 | | None -> 6 | print_endline "enter days: "; 7 | m base (read_int ())) ;; 8 | -------------------------------------------------------------------------------- /code/corebuild: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ocamlbuild \ 4 | -use-ocamlfind \ 5 | -classic-display \ 6 | -syntax camlp4o \ 7 | -pkg core,core_extended,async,textutils,core_bench \ 8 | -pkg sexplib.syntax,comparelib.syntax,fieldslib.syntax,variantslib.syntax \ 9 | -pkg bin_prot.syntax \ 10 | -tag thread \ 11 | -tag debug \ 12 | -cflags -short-paths \ 13 | -cflags "-w @A-4-33-41-42-43-34-44" \ 14 | -cflags -strict-sequence \ 15 | -cflags -principal \ 16 | $@ 17 | -------------------------------------------------------------------------------- /code/ctypes/ctypes_impl.ml: -------------------------------------------------------------------------------- 1 | let string = 2 | view (char ptr) 3 | ~read:string_of_char_ptr 4 | ~write:char_ptr_of_string 5 | -------------------------------------------------------------------------------- /code/error-handling/blow_up.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | exception Empty_list 3 | 4 | let list_max = function 5 | | [] -> raise Empty_list 6 | | hd :: tl -> List.fold tl ~init:hd ~f:(Int.max) 7 | 8 | let () = 9 | printf "%d\n" (list_max [1;2;3]); 10 | printf "%d\n" (list_max []) 11 | -------------------------------------------------------------------------------- /code/error-handling/build_blow_up.errsh: -------------------------------------------------------------------------------- 1 | corebuild blow_up.byte 2 | ./blow_up.byte 3 | -------------------------------------------------------------------------------- /code/error-handling/build_blow_up_notrace.errsh: -------------------------------------------------------------------------------- 1 | corebuild blow_up.byte 2 | OCAMLRUNPARAM= ./blow_up.byte 3 | -------------------------------------------------------------------------------- /code/error-handling/exn_cost.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Core_bench.Std 3 | 4 | let simple_computation () = 5 | List.range 0 10 6 | |> List.fold ~init:0 ~f:(fun sum x -> sum + x * x) 7 | |> ignore 8 | 9 | let simple_with_handler () = 10 | try simple_computation () with Exit -> () 11 | 12 | let end_with_exn () = 13 | try 14 | simple_computation (); 15 | raise Exit 16 | with Exit -> () 17 | 18 | let () = 19 | [ Bench.Test.create ~name:"simple computation" 20 | (fun () -> simple_computation ()); 21 | Bench.Test.create ~name:"simple computation w/handler" 22 | (fun () -> simple_with_handler ()); 23 | Bench.Test.create ~name:"end with exn" 24 | (fun () -> end_with_exn ()); 25 | ] 26 | |> Bench.make_command 27 | |> Command.run 28 | -------------------------------------------------------------------------------- /code/error-handling/result.ml: -------------------------------------------------------------------------------- 1 | module Result : sig 2 | type ('a,'b) t = | Ok of 'a 3 | | Error of 'b 4 | end 5 | -------------------------------------------------------------------------------- /code/error-handling/result.mli: -------------------------------------------------------------------------------- 1 | module Result : sig 2 | type ('a,'b) t = | Ok of 'a 3 | | Error of 'b 4 | end 5 | -------------------------------------------------------------------------------- /code/error-handling/run_exn_cost.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg core_bench exn_cost.native 2 | ./exn_cost.native -ascii cycles 3 | -------------------------------------------------------------------------------- /code/error-handling/run_exn_cost_notrace.sh: -------------------------------------------------------------------------------- 1 | OCAMLRUNPARAM= ./exn_cost.native -ascii cycles 2 | -------------------------------------------------------------------------------- /code/error-handling/sexpr.scm: -------------------------------------------------------------------------------- 1 | (This (is an) (s expression)) 2 | -------------------------------------------------------------------------------- /code/error-handling/try_with.syntax: -------------------------------------------------------------------------------- 1 | try with 2 | | -> 3 | | -> 4 | ... 5 | -------------------------------------------------------------------------------- /code/exec_script.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | cd $(dirname $1) 3 | while IFS= read -r line ; do 4 | echo "$ $line" 5 | bash -c "$line" 6 | done < $(basename $1) 7 | -------------------------------------------------------------------------------- /code/exec_topscript.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | topscript=`pwd`/../scripts/_build/run_core_toplevel.byte 4 | cd $(dirname $1) 5 | $(topscript) $(basename $1) 6 | -------------------------------------------------------------------------------- /code/fcm/build_query_handler.sh: -------------------------------------------------------------------------------- 1 | corebuild query_handler.byte 2 | -------------------------------------------------------------------------------- /code/fcm/build_query_handler_loader.sh: -------------------------------------------------------------------------------- 1 | corebuild query_handler_loader.byte 2 | -------------------------------------------------------------------------------- /code/fcm/fcm.syntax: -------------------------------------------------------------------------------- 1 | (module : ) 2 | -------------------------------------------------------------------------------- /code/fcm/loader_cli1.rawsh: -------------------------------------------------------------------------------- 1 | $ ./query_handler_loader.byte 2 | >>> (loader known_services) 3 | (ls unique) 4 | >>> (loader active_services) 5 | (loader) 6 | -------------------------------------------------------------------------------- /code/fcm/loader_cli2.rawsh: -------------------------------------------------------------------------------- 1 | >>> (ls .) 2 | Could not find matching handler: ls 3 | -------------------------------------------------------------------------------- /code/fcm/loader_cli3.rawsh: -------------------------------------------------------------------------------- 1 | >>> (loader (load ls /var)) 2 | () 3 | >>> (ls /var) 4 | (agentx at audit backups db empty folders jabberd lib log mail msgs named 5 | netboot pgsql_socket_alt root rpc run rwho spool tmp vm yp) 6 | >>> (loader (unload ls)) 7 | () 8 | >>> (ls /var) 9 | Could not find matching handler: ls 10 | -------------------------------------------------------------------------------- /code/fcm/loader_cli4.rawsh: -------------------------------------------------------------------------------- 1 | >>> (loader (unload loader)) 2 | It's unwise to unload yourself 3 | -------------------------------------------------------------------------------- /code/fcm/pack.syntax: -------------------------------------------------------------------------------- 1 | (module : ) 2 | -------------------------------------------------------------------------------- /code/fcm/query-syntax.scm: -------------------------------------------------------------------------------- 1 | (query-name query) 2 | -------------------------------------------------------------------------------- /code/fcm/query_example.rawscript: -------------------------------------------------------------------------------- 1 | $ ./query_handler.byte 2 | >>> (unique ()) 3 | 0 4 | >>> (unique ()) 5 | 1 6 | >>> (ls .) 7 | (agentx at audit backups db empty folders jabberd lib log mail msgs named 8 | netboot pgsql_socket_alt root rpc run rwho spool tmp vm yp) 9 | >>> (ls vm) 10 | (sleepimage swapfile0 swapfile1 swapfile2 swapfile3 swapfile4 swapfile5 11 | swapfile6) 12 | -------------------------------------------------------------------------------- /code/fcm/query_handler.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Query_handler_core 3 | 4 | (* part 1 *) 5 | let () = 6 | cli (build_dispatch_table [unique_instance; list_dir_instance]) 7 | -------------------------------------------------------------------------------- /code/fcm/query_handler_loader.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Query_handler_core 3 | (* part 1 *) 4 | let () = 5 | let loader = Loader.create [(module Unique); (module List_dir)] in 6 | let loader_instance = 7 | (module struct 8 | module Query_handler = Loader 9 | let this = loader 10 | end : Query_handler_instance) 11 | in 12 | Hashtbl.replace loader.Loader.active 13 | ~key:Loader.name ~data:loader_instance; 14 | cli loader.Loader.active 15 | 16 | -------------------------------------------------------------------------------- /code/fcm/unpack.syntax: -------------------------------------------------------------------------------- 1 | (val : ) 2 | -------------------------------------------------------------------------------- /code/ffi/build_datetime.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg ctypes.foreign datetime.native 2 | ./datetime.native 3 | ./datetime.native -a 4 | -------------------------------------------------------------------------------- /code/ffi/build_hello.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg ctypes.foreign -lflags -cclib,-lncurses hello.native 2 | -------------------------------------------------------------------------------- /code/ffi/build_qsort.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg ctypes.foreign qsort.native 2 | cat input.txt 3 | ./qsort.native < input.txt 4 | corebuild -pkg ctypes.foreign qsort.inferred.mli 5 | cp _build/qsort.inferred.mli qsort.mli 6 | -------------------------------------------------------------------------------- /code/ffi/hello.ml: -------------------------------------------------------------------------------- 1 | open Ncurses 2 | 3 | let () = 4 | let main_window = initscr () in 5 | ignore(cbreak ()); 6 | let small_window = newwin 10 10 5 5 in 7 | mvwaddstr main_window 1 2 "Hello"; 8 | mvwaddstr small_window 2 2 "World"; 9 | box small_window '\000' '\000'; 10 | refresh (); 11 | Unix.sleep 1; 12 | wrefresh small_window; 13 | Unix.sleep 5; 14 | endwin () 15 | -------------------------------------------------------------------------------- /code/ffi/infer_ncurses.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg ctypes.foreign ncurses.inferred.mli 2 | cp _build/ncurses.inferred.mli . 3 | -------------------------------------------------------------------------------- /code/ffi/input.txt: -------------------------------------------------------------------------------- 1 | 5 2 | 3 3 | 2 4 | 1 5 | 4 6 | -------------------------------------------------------------------------------- /code/ffi/install.rawsh: -------------------------------------------------------------------------------- 1 | $ brew install libffi # for MacOS X users 2 | $ opam install ctypes 3 | $ utop 4 | # require "ctypes.foreign" ;; 5 | -------------------------------------------------------------------------------- /code/ffi/ncurses.h: -------------------------------------------------------------------------------- 1 | typedef struct _win_st WINDOW; 2 | typedef unsigned int chtype; 3 | 4 | WINDOW *initscr (void); 5 | WINDOW *newwin (int, int, int, int); 6 | void endwin (void); 7 | void refresh (void); 8 | void wrefresh (WINDOW *); 9 | void addstr (const char *); 10 | int mvwaddch (WINDOW *, int, int, const chtype); 11 | void mvwaddstr (WINDOW *, int, int, char *); 12 | void box (WINDOW *, chtype, chtype); 13 | int cbreak (void); 14 | -------------------------------------------------------------------------------- /code/ffi/ncurses.inferred.mli: -------------------------------------------------------------------------------- 1 | type window = unit Ctypes.ptr 2 | val window : window Ctypes.typ 3 | val initscr : unit -> window 4 | val endwin : unit -> unit 5 | val refresh : unit -> unit 6 | val wrefresh : window -> unit 7 | val newwin : int -> int -> int -> int -> window 8 | val mvwaddch : window -> int -> int -> char -> unit 9 | val addstr : string -> unit 10 | val mvwaddstr : window -> int -> int -> string -> unit 11 | val box : window -> int -> int -> unit 12 | val cbreak : unit -> unit 13 | -------------------------------------------------------------------------------- /code/ffi/ncurses.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | 3 | type window = unit ptr 4 | let window : window typ = ptr void 5 | 6 | (* part 1 *) 7 | open Foreign 8 | 9 | let initscr = 10 | foreign "initscr" (void @-> returning window) 11 | 12 | (* part 2 *) 13 | let newwin = 14 | foreign "newwin" 15 | (int @-> int @-> int @-> int @-> returning window) 16 | 17 | let endwin = 18 | foreign "endwin" (void @-> returning void) 19 | 20 | let refresh = 21 | foreign "refresh" (void @-> returning void) 22 | 23 | let wrefresh = 24 | foreign "wrefresh" (window @-> returning void) 25 | 26 | let addstr = 27 | foreign "addstr" (string @-> returning void) 28 | 29 | let mvwaddch = 30 | foreign "mvwaddch" 31 | (window @-> int @-> int @-> char @-> returning void) 32 | 33 | let mvwaddstr = 34 | foreign "mvwaddstr" 35 | (window @-> int @-> int @-> string @-> returning void) 36 | 37 | let box = 38 | foreign "box" (window @-> char @-> char @-> returning void) 39 | 40 | let cbreak = 41 | foreign "cbreak" (void @-> returning int) 42 | -------------------------------------------------------------------------------- /code/ffi/ncurses.mli: -------------------------------------------------------------------------------- 1 | type window 2 | val window : window Ctypes.typ 3 | val initscr : unit -> window 4 | val endwin : unit -> unit 5 | val refresh : unit -> unit 6 | val wrefresh : window -> unit 7 | val newwin : int -> int -> int -> int -> window 8 | val mvwaddch : window -> int -> int -> char -> unit 9 | val addstr : string -> unit 10 | val mvwaddstr : window -> int -> int -> string -> unit 11 | val box : window -> char -> char -> unit 12 | val cbreak : unit -> int 13 | -------------------------------------------------------------------------------- /code/ffi/posix_headers.h: -------------------------------------------------------------------------------- 1 | time_t time(time_t *); 2 | double difftime(time_t, time_t); 3 | char *ctime(const time_t *timep); 4 | -------------------------------------------------------------------------------- /code/ffi/qsort.h: -------------------------------------------------------------------------------- 1 | void qsort(void *base, size_t nmemb, size_t size, 2 | int(*compar)(const void *, const void *)); 3 | -------------------------------------------------------------------------------- /code/ffi/qsort.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Ctypes 3 | open PosixTypes 4 | open Foreign 5 | 6 | let compare_t = ptr void @-> ptr void @-> returning int 7 | 8 | let qsort = foreign "qsort" 9 | (ptr void @-> size_t @-> size_t @-> funptr compare_t @-> 10 | returning void) 11 | 12 | let qsort' cmp arr = 13 | let open Unsigned.Size_t in 14 | let ty = Array.element_type arr in 15 | let len = of_int (Array.length arr) in 16 | let elsize = of_int (sizeof ty) in 17 | let start = to_voidp (Array.start arr) in 18 | let compare l r = cmp (!@ (from_voidp ty l)) (!@ (from_voidp ty r)) in 19 | qsort start len elsize compare; 20 | arr 21 | 22 | let sort_stdin () = 23 | In_channel.input_lines stdin 24 | |> List.map ~f:int_of_string 25 | |> Array.of_list int 26 | |> qsort' Int.compare 27 | |> Array.to_list 28 | |> List.iter ~f:(fun a -> printf "%d\n" a) 29 | 30 | let () = 31 | Command.basic ~summary:"Sort integers on standard input" 32 | Command.Spec.empty sort_stdin 33 | |> Command.run 34 | -------------------------------------------------------------------------------- /code/ffi/qsort.mli: -------------------------------------------------------------------------------- 1 | val compare_t : (unit Ctypes.ptr -> unit Ctypes.ptr -> int) Ctypes.fn 2 | val qsort : 3 | unit Ctypes.ptr -> 4 | PosixTypes.size_t -> 5 | PosixTypes.size_t -> (unit Ctypes.ptr -> unit Ctypes.ptr -> int) -> unit 6 | val qsort' : ('a -> 'a -> int) -> 'a Ctypes.array -> 'a Ctypes.array 7 | val sort_stdin : unit -> unit 8 | -------------------------------------------------------------------------------- /code/ffi/qsort.topscript: -------------------------------------------------------------------------------- 1 | #require "ctypes.foreign" ;; 2 | open Ctypes ;; 3 | open PosixTypes ;; 4 | open Foreign ;; 5 | let compare_t = ptr void @-> ptr void @-> returning int ;; 6 | let qsort = foreign "qsort" 7 | (ptr void @-> size_t @-> size_t @-> 8 | funptr compare_t @-> returning void) ;; 9 | -------------------------------------------------------------------------------- /code/ffi/qsort_typedef.h: -------------------------------------------------------------------------------- 1 | typedef int(compare_t)(const void *, const void *); 2 | 3 | void qsort(void *base, size_t nmemb, size_t size, compare_t *); 4 | -------------------------------------------------------------------------------- /code/ffi/return_c_frag.c: -------------------------------------------------------------------------------- 1 | uncurried_C(3, 4); 2 | -------------------------------------------------------------------------------- /code/ffi/return_c_frag.h: -------------------------------------------------------------------------------- 1 | int uncurried_C(int, int); 2 | -------------------------------------------------------------------------------- /code/ffi/return_c_uncurried.c: -------------------------------------------------------------------------------- 1 | /* A function that accepts an int, and returns a function 2 | pointer that accepts a second int and returns an int. */ 3 | typedef int (function_t)(int); 4 | function_t *curried_C(int); 5 | 6 | /* supply both arguments */ 7 | curried_C(3)(4); 8 | 9 | /* supply one argument at a time */ 10 | function_t *f = curried_C(3); f(4); 11 | -------------------------------------------------------------------------------- /code/ffi/return_frag.ml: -------------------------------------------------------------------------------- 1 | (* correct types *) 2 | val time: ptr time_t @-> returning time_t 3 | val difftime: time_t @-> time_t @-> returning double 4 | (* part 1 *) 5 | (* incorrect types *) 6 | val time: ptr time_t @-> time_t 7 | val difftime: time_t @-> time_t @-> double 8 | (* part 2 *) 9 | val curried : int -> int -> int 10 | (* part 3 *) 11 | val curried : int -> (int -> int) 12 | -------------------------------------------------------------------------------- /code/ffi/timeval_headers.h: -------------------------------------------------------------------------------- 1 | struct timeval { 2 | long tv_sec; 3 | long tv_usec; 4 | }; 5 | 6 | int gettimeofday(struct timeval *, struct timezone *tv); 7 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-cyclic1/build.errsh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-cyclic1/counter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t = int String.Map.t 4 | 5 | let empty = String.Map.empty 6 | 7 | let to_list t = Map.to_alist t 8 | 9 | let touch t s = 10 | let count = 11 | match Map.find t s with 12 | | None -> 0 13 | | Some x -> x 14 | in 15 | Map.add t ~key:s ~data:(count + 1) 16 | 17 | (* part 1 *) 18 | let singleton l = Counter.touch Counter.empty 19 | 20 | (* part 2 *) 21 | type median = | Median of string 22 | | Before_and_after of string * string 23 | 24 | let median t = 25 | let sorted_strings = List.sort (Map.to_alist t) 26 | ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 27 | in 28 | let len = List.length sorted_strings in 29 | if len = 0 then failwith "median: empty frequency count"; 30 | let nth n = fst (List.nth_exn sorted_strings n) in 31 | if len mod 2 = 1 32 | then Median (nth (len/2)) 33 | else Before_and_after (nth (len/2 - 1), nth (len/2));; 34 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-cyclic1/counter.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (** A collection of string frequency counts *) 4 | type t 5 | 6 | (** The empty set of frequency counts *) 7 | val empty : t 8 | 9 | (** Bump the frequency count for the given string. *) 10 | val touch : t -> string -> t 11 | 12 | (* Converts the set of frequency counts to an association list. Every strings 13 | in the list will show up at most once, and the integers will be at least 14 | 1. *) 15 | val to_list : t -> (string * int) list 16 | 17 | (** Represents the median computed from a set of strings. In the case where 18 | there is an even number of choices, the one before and after the median is 19 | returned. *) 20 | type median = | Median of string 21 | | Before_and_after of string * string 22 | 23 | val median : t -> median 24 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-cyclic1/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:Counter.empty ~f:Counter.touch 5 | 6 | let () = 7 | build_counts () 8 | |> Counter.to_list 9 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 10 | |> (fun counts -> List.take counts 10) 11 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 12 | 13 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-cyclic2/build.errsh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-cyclic2/counter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t = int String.Map.t 4 | 5 | let empty = String.Map.empty 6 | 7 | let to_list t = Map.to_alist t 8 | 9 | let touch t s = 10 | let count = 11 | match Map.find t s with 12 | | None -> 0 13 | | Some x -> x 14 | in 15 | Map.add t ~key:s ~data:(count + 1) 16 | 17 | (* part 1 *) 18 | let _build_counts = Freq.build_counts 19 | 20 | (* part 2 *) 21 | type median = | Median of string 22 | | Before_and_after of string * string 23 | 24 | let median t = 25 | let sorted_strings = List.sort (Map.to_alist t) 26 | ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 27 | in 28 | let len = List.length sorted_strings in 29 | if len = 0 then failwith "median: empty frequency count"; 30 | let nth n = fst (List.nth_exn sorted_strings n) in 31 | if len mod 2 = 1 32 | then Median (nth (len/2)) 33 | else Before_and_after (nth (len/2 - 1), nth (len/2));; 34 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-cyclic2/counter.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (** A collection of string frequency counts *) 4 | type t 5 | 6 | (** The empty set of frequency counts *) 7 | val empty : t 8 | 9 | (** Bump the frequency count for the given string. *) 10 | val touch : t -> string -> t 11 | 12 | (* Converts the set of frequency counts to an association list. Every strings 13 | in the list will show up at most once, and the integers will be at least 14 | 1. *) 15 | val to_list : t -> (string * int) list 16 | 17 | (** Represents the median computed from a set of strings. In the case where 18 | there is an even number of choices, the one before and after the median is 19 | returned. *) 20 | type median = | Median of string 21 | | Before_and_after of string * string 22 | 23 | val median : t -> median 24 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-cyclic2/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:Counter.empty ~f:Counter.touch 5 | 6 | let () = 7 | build_counts () 8 | |> Counter.to_list 9 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 10 | |> (fun counts -> List.take counts 10) 11 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 12 | 13 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-fast/build.sh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-fast/counter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t = int String.Map.t 4 | 5 | let empty = String.Map.empty 6 | 7 | let to_list t = Map.to_alist t 8 | 9 | let touch t s = 10 | let count = 11 | match Map.find t s with 12 | | None -> 0 13 | | Some x -> x 14 | in 15 | Map.add t ~key:s ~data:(count + 1) 16 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-fast/counter.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (** A collection of string frequency counts *) 4 | type t 5 | 6 | (** The empty set of frequency counts *) 7 | val empty : t 8 | 9 | (** Bump the frequency count for the given string. *) 10 | val touch : t -> string -> t 11 | 12 | (* Converts the set of frequency counts to an association list. Every strings 13 | in the list will show up at most once, and the integers will be at least 14 | 1. *) 15 | val to_list : t -> (string * int) list 16 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-fast/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:Counter.empty ~f:Counter.touch 5 | 6 | let () = 7 | build_counts () 8 | |> Counter.to_list 9 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 10 | |> (fun counts -> List.take counts 10) 11 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 12 | 13 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-median/build.sh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-median/build_use_median.sh: -------------------------------------------------------------------------------- 1 | ../corebuild use_median_1.native 2 | ../corebuild use_median_2.native 3 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-median/counter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t = int String.Map.t 4 | 5 | let empty = String.Map.empty 6 | 7 | let to_list t = Map.to_alist t 8 | 9 | let touch t s = 10 | let count = 11 | match Map.find t s with 12 | | None -> 0 13 | | Some x -> x 14 | in 15 | Map.add t ~key:s ~data:(count + 1) 16 | 17 | (* part 1 *) 18 | type median = | Median of string 19 | | Before_and_after of string * string 20 | 21 | let median t = 22 | let sorted_strings = List.sort (Map.to_alist t) 23 | ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 24 | in 25 | let len = List.length sorted_strings in 26 | if len = 0 then failwith "median: empty frequency count"; 27 | let nth n = fst (List.nth_exn sorted_strings n) in 28 | if len mod 2 = 1 29 | then Median (nth (len/2)) 30 | else Before_and_after (nth (len/2 - 1), nth (len/2));; 31 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-median/counter.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (** A collection of string frequency counts *) 4 | type t 5 | 6 | (** The empty set of frequency counts *) 7 | val empty : t 8 | 9 | (** Bump the frequency count for the given string. *) 10 | val touch : t -> string -> t 11 | 12 | (* Converts the set of frequency counts to an association list. Every strings 13 | in the list will show up at most once, and the integers will be at least 14 | 1. *) 15 | val to_list : t -> (string * int) list 16 | 17 | (* part 1 *) 18 | (** Represents the median computed from a set of strings. In the case where 19 | there is an even number of choices, the one before and after the median is 20 | returned. *) 21 | type median = | Median of string 22 | | Before_and_after of string * string 23 | 24 | val median : t -> median 25 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-median/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:Counter.empty ~f:Counter.touch 5 | 6 | let () = 7 | build_counts () 8 | |> Counter.to_list 9 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 10 | |> (fun counts -> List.take counts 10) 11 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 12 | 13 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-median/use_median_1.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (* part 1 *) 4 | let print_median m = 5 | match m with 6 | | Counter.Median string -> printf "True median:\n %s\n" string 7 | | Counter.Before_and_after (before, after) -> 8 | printf "Before and after median:\n %s\n %s\n" before after 9 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-median/use_median_2.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (* part 1 *) 4 | let print_median m = 5 | let module C = Counter in 6 | match m with 7 | | C.Median string -> printf "True median:\n %s\n" string 8 | | C.Before_and_after (before, after) -> 9 | printf "Before and after median:\n %s\n %s\n" before after 10 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-obuild/build.sh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-obuild/freq.ml: -------------------------------------------------------------------------------- 1 | ../files-modules-and-programs-freq/freq.ml -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-obuild/test.sh: -------------------------------------------------------------------------------- 1 | strings `which ocamlopt` | ./freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-counter/build.sh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-counter/counter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let touch t s = 4 | let count = 5 | match List.Assoc.find t s with 6 | | None -> 0 7 | | Some x -> x 8 | in 9 | List.Assoc.add t s (count + 1) 10 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-counter/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:[] ~f:Counter.touch 5 | 6 | let () = 7 | build_counts () 8 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 9 | |> (fun l -> List.take l 10) 10 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 11 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-counter/infer_mli.sh: -------------------------------------------------------------------------------- 1 | corebuild counter.inferred.mli 2 | cat _build/counter.inferred.mli 3 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-missing-def/build.errsh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-missing-def/counter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t = int String.Map.t 4 | 5 | let empty = String.Map.empty 6 | 7 | let to_list t = Map.to_alist t 8 | 9 | let touch t s = 10 | let count = 11 | match Map.find t s with 12 | | None -> 0 13 | | Some x -> x 14 | in 15 | Map.add t ~key:s ~data:(count + 1) 16 | 17 | (* part 1 *) 18 | type median = | Median of string 19 | | Before_and_after of string * string 20 | 21 | let median t = 22 | let sorted_strings = List.sort (Map.to_alist t) 23 | ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 24 | in 25 | let len = List.length sorted_strings in 26 | if len = 0 then failwith "median: empty frequency count"; 27 | let nth n = fst (List.nth_exn sorted_strings n) in 28 | if len mod 2 = 1 29 | then Median (nth (len/2)) 30 | else Before_and_after (nth (len/2 - 1), nth (len/2));; 31 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-missing-def/counter.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (** A collection of string frequency counts *) 4 | type t 5 | 6 | (** The empty set of frequency counts *) 7 | val empty : t 8 | 9 | (** Bump the frequency count for the given string. *) 10 | val touch : t -> string -> t 11 | 12 | (* Converts the set of frequency counts to an association list. Every strings 13 | in the list will show up at most once, and the integers will be at least 14 | 1. *) 15 | val to_list : t -> (string * int) list 16 | 17 | (* part 1 *) 18 | val count : t -> string -> int 19 | 20 | (* part 2 *) 21 | (** Represents the median computed from a set of strings. In the case where 22 | there is an even number of choices, the one before and after the median is 23 | returned. *) 24 | type median = | Median of string 25 | | Before_and_after of string * string 26 | 27 | val median : t -> median 28 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-missing-def/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:Counter.empty ~f:Counter.touch 5 | 6 | let () = 7 | build_counts () 8 | |> Counter.to_list 9 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 10 | |> (fun counts -> List.take counts 10) 11 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 12 | 13 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-abstract-fixed/build.sh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-abstract-fixed/counter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t = (string * int) list 4 | 5 | let empty = [] 6 | 7 | let to_list x = x 8 | 9 | let touch t s = 10 | let count = 11 | match List.Assoc.find t s with 12 | | None -> 0 13 | | Some x -> x 14 | in 15 | List.Assoc.add t s (count + 1) 16 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-abstract-fixed/counter.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (** A collection of string frequency counts *) 4 | type t 5 | 6 | (** The empty set of frequency counts *) 7 | val empty : t 8 | 9 | (** Bump the frequency count for the given string. *) 10 | val touch : t -> string -> t 11 | 12 | (* Converts the set of frequency counts to an association list. Every strings 13 | in the list will show up at most once, and the integers will be at least 14 | 1. *) 15 | val to_list : t -> (string * int) list 16 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-abstract-fixed/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:Counter.empty ~f:Counter.touch 5 | 6 | let () = 7 | build_counts () 8 | |> Counter.to_list 9 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 10 | |> (fun counts -> List.take counts 10) 11 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 12 | 13 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-abstract/build.errsh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-abstract/counter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t = (string * int) list 4 | 5 | let empty = [] 6 | 7 | let to_list x = x 8 | 9 | let touch t s = 10 | let count = 11 | match List.Assoc.find t s with 12 | | None -> 0 13 | | Some x -> x 14 | in 15 | List.Assoc.add t s (count + 1) 16 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-abstract/counter.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (** A collection of string frequency counts *) 4 | type t 5 | 6 | (** The empty set of frequency counts *) 7 | val empty : t 8 | 9 | (** Bump the frequency count for the given string. *) 10 | val touch : t -> string -> t 11 | 12 | (** Converts the set of frequency counts to an association list. A string shows 13 | up at most once, and the counts are >= 1. *) 14 | val to_list : t -> (string * int) list 15 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-abstract/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:[] ~f:Counter.touch 5 | 6 | let () = 7 | build_counts () 8 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 9 | |> (fun l -> List.take l 10) 10 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 11 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-mismatch/build.errsh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-mismatch/counter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t = int String.Map.t 4 | 5 | let empty = String.Map.empty 6 | 7 | let to_list t = Map.to_alist t 8 | 9 | let touch t s = 10 | let count = 11 | match Map.find t s with 12 | | None -> 0 13 | | Some x -> x 14 | in 15 | Map.add t ~key:s ~data:(count + 1) 16 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-mismatch/counter.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (** A collection of string frequency counts *) 4 | type t 5 | 6 | (** The empty set of frequency counts *) 7 | val empty : t 8 | 9 | (* part 1 *) 10 | (** Bump the frequency count for the given string. *) 11 | val touch : string -> t -> t 12 | (* part 2 *) 13 | 14 | (* Converts the set of frequency counts to an association list. Every strings 15 | in the list will show up at most once, and the integers will be at least 16 | 1. *) 17 | val to_list : t -> (string * int) list 18 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig-mismatch/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:Counter.empty ~f:Counter.touch 5 | 6 | let () = 7 | build_counts () 8 | |> Counter.to_list 9 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 10 | |> (fun counts -> List.take counts 10) 11 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 12 | 13 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig/build.sh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig/counter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let touch t s = 4 | let count = 5 | match List.Assoc.find t s with 6 | | None -> 0 7 | | Some x -> x 8 | in 9 | List.Assoc.add t s (count + 1) 10 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig/counter.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (** Bump the frequency count for the given string. *) 4 | val touch : (string * int) list -> string -> (string * int) list 5 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-sig/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:[] ~f:Counter.touch 5 | 6 | let () = 7 | build_counts () 8 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 9 | |> (fun l -> List.take l 10) 10 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 11 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-type-mismatch/build.errsh: -------------------------------------------------------------------------------- 1 | corebuild freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-type-mismatch/counter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t = int String.Map.t 4 | 5 | let empty = String.Map.empty 6 | 7 | let to_list t = Map.to_alist t 8 | 9 | let touch t s = 10 | let count = 11 | match Map.find t s with 12 | | None -> 0 13 | | Some x -> x 14 | in 15 | Map.add t ~key:s ~data:(count + 1) 16 | 17 | (* part 1 *) 18 | type median = | Median of string 19 | | Before_and_after of string * string 20 | 21 | let median t = 22 | let sorted_strings = List.sort (Map.to_alist t) 23 | ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 24 | in 25 | let len = List.length sorted_strings in 26 | if len = 0 then failwith "median: empty frequency count"; 27 | let nth n = fst (List.nth_exn sorted_strings n) in 28 | if len mod 2 = 1 29 | then Median (nth (len/2)) 30 | else Before_and_after (nth (len/2 - 1), nth (len/2));; 31 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-type-mismatch/counter.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (** A collection of string frequency counts *) 4 | type t 5 | 6 | (** The empty set of frequency counts *) 7 | val empty : t 8 | 9 | (** Bump the frequency count for the given string. *) 10 | val touch : t -> string -> t 11 | 12 | (* Converts the set of frequency counts to an association list. Every strings 13 | in the list will show up at most once, and the integers will be at least 14 | 1. *) 15 | val to_list : t -> (string * int) list 16 | 17 | (* part 1 *) 18 | (** Represents the median computed from a set of strings. In the case where 19 | there is an even number of choices, the one before and after the median is 20 | returned. *) 21 | type median = | Before_and_after of string * string 22 | | Median of string 23 | (* part 2 *) 24 | val median : t -> median 25 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq-with-type-mismatch/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:Counter.empty ~f:Counter.touch 5 | 6 | let () = 7 | build_counts () 8 | |> Counter.to_list 9 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 10 | |> (fun counts -> List.take counts 10) 11 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 12 | 13 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:[] ~f:(fun counts line -> 5 | let count = 6 | match List.Assoc.find counts line with 7 | | None -> 0 8 | | Some x -> x 9 | in 10 | List.Assoc.add counts line (count + 1) 11 | ) 12 | 13 | let () = 14 | build_counts () 15 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 16 | |> (fun l -> List.take l 10) 17 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 18 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq/simple_build.sh: -------------------------------------------------------------------------------- 1 | ocamlfind ocamlc -linkpkg -thread -package core freq.ml -o freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs-freq/simple_build_fail.errsh: -------------------------------------------------------------------------------- 1 | ocamlc freq.ml -o freq.byte 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/abstract_username.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | module Username : sig 4 | type t 5 | val of_string : string -> t 6 | val to_string : t -> string 7 | end = struct 8 | type t = string 9 | let of_string x = x 10 | let to_string x = x 11 | end 12 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/build_session_info.errsh: -------------------------------------------------------------------------------- 1 | corebuild session_info.native 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/common.ml: -------------------------------------------------------------------------------- 1 | module List = Ext_list 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/confusing_username_and_host.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | module type ID = sig 4 | type t 5 | val of_string : string -> t 6 | val to_string : t -> string 7 | end 8 | 9 | module String_id = struct 10 | type t = string 11 | let of_string x = x 12 | let to_string x = x 13 | end 14 | 15 | module Username : ID = String_id 16 | module Hostname : ID = String_id 17 | 18 | type session_info = { user: Username.t; 19 | host: Hostname.t; 20 | when_started: Time.t; 21 | } 22 | 23 | let sessions_have_same_user s1 s2 = 24 | s1.user = s2.host 25 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/ext_list.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (* The new function we're going to add *) 4 | let rec intersperse list el = 5 | match list with 6 | | [] | [ _ ] -> list 7 | | x :: y :: tl -> x :: el :: intersperse (y::tl) el 8 | 9 | (* The remainder of the list module *) 10 | include List 11 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/ext_list.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | (* Include the interface of the list module from Core *) 4 | include (module type of List) 5 | 6 | (* Signature of function we're adding *) 7 | val intersperse : 'a list -> 'a -> 'a list 8 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/freq.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let build_counts () = 4 | In_channel.fold_lines stdin ~init:[] ~f:(fun counts line -> 5 | let count = 6 | match List.Assoc.find counts line with 7 | | None -> 0 8 | | Some x -> x 9 | in 10 | List.Assoc.add counts line (count + 1) 11 | ) 12 | 13 | let () = 14 | build_counts () 15 | |> List.sort ~cmp:(fun (_,x) (_,y) -> Int.descending x y) 16 | |> (fun l -> List.take l 10) 17 | |> List.iter ~f:(fun (line,count) -> printf "%3d: %s\n" count line) 18 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/intro.topscript: -------------------------------------------------------------------------------- 1 | let assoc = [("one", 1); ("two",2); ("three",3)] ;; 2 | List.Assoc.find assoc "two" ;; 3 | List.Assoc.add assoc "four" 4 (* add a new key *) ;; 4 | List.Assoc.add assoc "two" 4 (* overwrite an existing key *) ;; 5 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/main.topscript: -------------------------------------------------------------------------------- 1 | module M = struct let foo = 3 end;; 2 | foo;; 3 | open M;; 4 | foo;; 5 | #part 1 6 | let average x y = 7 | let open Int64 in 8 | x + y / of_int 2;; 9 | #part 2 10 | let average x y = 11 | Int64.(x + y / of_int 2);; 12 | #part 3 13 | module Interval = struct 14 | type t = | Interval of int * int 15 | | Empty 16 | 17 | let create low high = 18 | if high < low then Empty else Interval (low,high) 19 | end;; 20 | #part 4 21 | module Extended_interval = struct 22 | include Interval 23 | 24 | let contains t x = 25 | match t with 26 | | Empty -> false 27 | | Interval (low,high) -> x >= low && x <= high 28 | end;; 29 | Extended_interval.contains (Extended_interval.create 3 10) 4;; 30 | #part 5 31 | module Extended_interval = struct 32 | open Interval 33 | 34 | let contains t x = 35 | match t with 36 | | Empty -> false 37 | | Interval (low,high) -> x >= low && x <= high 38 | end;; 39 | Extended_interval.contains (Extended_interval.create 3 10) 4;; 40 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/module.syntax: -------------------------------------------------------------------------------- 1 | module : = 2 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/session_info.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | module type ID = sig 4 | type t 5 | val of_string : string -> t 6 | val to_string : t -> string 7 | end 8 | 9 | module String_id = struct 10 | type t = string 11 | let of_string x = x 12 | let to_string x = x 13 | end 14 | 15 | module Username : ID = String_id 16 | module Hostname : ID = String_id 17 | 18 | type session_info = { user: Username.t; 19 | host: Hostname.t; 20 | when_started: Time.t; 21 | } 22 | 23 | let sessions_have_same_user s1 s2 = 24 | s1.user = s2.host 25 | -------------------------------------------------------------------------------- /code/files-modules-and-programs/val.syntax: -------------------------------------------------------------------------------- 1 | val : 2 | -------------------------------------------------------------------------------- /code/front-end/alice.ml: -------------------------------------------------------------------------------- 1 | let friends = [ Bob.name ] 2 | -------------------------------------------------------------------------------- /code/front-end/alice.mli: -------------------------------------------------------------------------------- 1 | val friends : Bob.t list 2 | -------------------------------------------------------------------------------- /code/front-end/alice_combined.ml: -------------------------------------------------------------------------------- 1 | module Alice : sig 2 | val friends : Bob.t list 3 | end = struct 4 | let friends = [ Bob.name ] 5 | end 6 | -------------------------------------------------------------------------------- /code/front-end/broken_module.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | module MyString = String; 3 | () 4 | -------------------------------------------------------------------------------- /code/front-end/broken_poly.ml: -------------------------------------------------------------------------------- 1 | let rec algebra = 2 | function 3 | | `Add (x,y) -> (algebra x) + (algebra y) 4 | | `Sub (x,y) -> (algebra x) - (algebra y) 5 | | `Mul (x,y) -> (algebra x) * (algebra y) 6 | | `Num x -> x 7 | 8 | let _ = 9 | algebra ( 10 | `Add ( 11 | (`Num 0), 12 | (`Sub ( 13 | (`Num 1), 14 | (`Mul ( 15 | (`Nu 3),(`Num 2) 16 | )) 17 | )) 18 | )) 19 | -------------------------------------------------------------------------------- /code/front-end/broken_poly_with_annot.ml: -------------------------------------------------------------------------------- 1 | type t = [ 2 | | `Add of t * t 3 | | `Sub of t * t 4 | | `Mul of t * t 5 | | `Num of int 6 | ] 7 | 8 | let rec algebra (x:t) = 9 | match x with 10 | | `Add (x,y) -> (algebra x) + (algebra y) 11 | | `Sub (x,y) -> (algebra x) - (algebra y) 12 | | `Mul (x,y) -> (algebra x) * (algebra y) 13 | | `Num x -> x 14 | 15 | let _ = 16 | algebra ( 17 | `Add ( 18 | (`Num 0), 19 | (`Sub ( 20 | (`Num 1), 21 | (`Mul ( 22 | (`Nu 3),(`Num 2) 23 | )) 24 | )) 25 | )) 26 | -------------------------------------------------------------------------------- /code/front-end/build_broken_module.errsh: -------------------------------------------------------------------------------- 1 | ocamlc -c broken_module.ml 2 | -------------------------------------------------------------------------------- /code/front-end/build_broken_poly.errsh: -------------------------------------------------------------------------------- 1 | ocamlc -c broken_poly.ml 2 | -------------------------------------------------------------------------------- /code/front-end/build_broken_poly_with_annot.errsh: -------------------------------------------------------------------------------- 1 | ocamlc -i broken_poly_with_annot.ml 2 | -------------------------------------------------------------------------------- /code/front-end/build_follow_on_function.errsh: -------------------------------------------------------------------------------- 1 | ocamlc -c follow_on_function.ml 2 | -------------------------------------------------------------------------------- /code/front-end/build_non_principal.sh: -------------------------------------------------------------------------------- 1 | ocamlc -i -principal non_principal.ml 2 | -------------------------------------------------------------------------------- /code/front-end/build_ocamldoc.rawsh: -------------------------------------------------------------------------------- 1 | $ mkdir -p html man/man3 2 | $ ocamldoc -html -d html doc.ml 3 | $ ocamldoc -man -d man/man3 doc.ml 4 | $ man -M man Doc 5 | -------------------------------------------------------------------------------- /code/front-end/build_principal.sh: -------------------------------------------------------------------------------- 1 | ocamlc -i -principal principal.ml 2 | -------------------------------------------------------------------------------- /code/front-end/build_type_conv_with_camlp4.rawsh: -------------------------------------------------------------------------------- 1 | $ ocamlfind ocamlc -c -syntax camlp4o -package sexplib.syntax \ 2 | -package fieldslib.syntax type_conv_example.ml 3 | -------------------------------------------------------------------------------- /code/front-end/build_type_conv_without_camlp4.errsh: -------------------------------------------------------------------------------- 1 | ocamlfind ocamlc -c type_conv_example.ml 2 | -------------------------------------------------------------------------------- /code/front-end/camlp4_dump.cmd: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | OCAMLFIND="ocamlfind query -predicates syntax,preprocessor -r" 4 | INCLUDE=`$OCAMLFIND -i-format comparelib.syntax` 5 | ARCHIVES=`$OCAMLFIND -a-format comparelib.syntax` 6 | camlp4o -printer o $INCLUDE $ARCHIVES $1 7 | -------------------------------------------------------------------------------- /code/front-end/camlp4_toplevel.topscript: -------------------------------------------------------------------------------- 1 | #use "topfind" ;; 2 | #camlp4o ;; 3 | #part 1 4 | #require "comparelib.syntax" ;; 5 | type t = { foo: string; bar : t } ;; 6 | type t = { foo: string; bar: t } with compare ;; 7 | -------------------------------------------------------------------------------- /code/front-end/comparelib_test.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | foo: string; 3 | bar: t 4 | } with compare 5 | -------------------------------------------------------------------------------- /code/front-end/comparelib_test.mli: -------------------------------------------------------------------------------- 1 | type t = { 2 | foo: string; 3 | bar: t 4 | } with compare 5 | -------------------------------------------------------------------------------- /code/front-end/conflicting_interfaces.errsh: -------------------------------------------------------------------------------- 1 | echo type t = Foo > test.ml 2 | echo type t = Bar > test.mli 3 | ocamlc -c test.mli test.ml 4 | -------------------------------------------------------------------------------- /code/front-end/doc.ml: -------------------------------------------------------------------------------- 1 | (** example.ml: The first special comment of the file is the comment 2 | associated with the whole module. *) 3 | 4 | (** Comment for exception My_exception. *) 5 | exception My_exception of (int -> int) * int 6 | 7 | (** Comment for type [weather] *) 8 | type weather = 9 | | Rain of int (** The comment for construtor Rain *) 10 | | Sun (** The comment for constructor Sun *) 11 | 12 | (** Find the current weather for a country 13 | @author Anil Madhavapeddy 14 | @param location The country to get the weather for. 15 | *) 16 | let what_is_the_weather_in location = 17 | match location with 18 | | `Cambridge -> Rain 100 19 | | `New_york -> Rain 20 20 | | `California -> Sun 21 | -------------------------------------------------------------------------------- /code/front-end/fixed_module.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let module MyString = String in 3 | () 4 | -------------------------------------------------------------------------------- /code/front-end/follow_on_function.ml: -------------------------------------------------------------------------------- 1 | let concat_and_print x y = 2 | let v = x ^ y in 3 | print_endline v; 4 | v; 5 | 6 | let add_and_print x y = 7 | let v = x + y in 8 | print_endline (string_of_int v); 9 | v 10 | 11 | let () = 12 | let _x = add_and_print 1 2 in 13 | let _y = concat_and_print "a" "b" in 14 | () 15 | -------------------------------------------------------------------------------- /code/front-end/follow_on_function_fixed.ml: -------------------------------------------------------------------------------- 1 | let concat_and_print x y = 2 | let v = x ^ y in 3 | print_endline v; 4 | v 5 | 6 | let add_and_print x y = 7 | let v = x + y in 8 | print_endline (string_of_int v); 9 | v 10 | 11 | let () = 12 | let _x = add_and_print 1 2 in 13 | let _y = concat_and_print "a" "b" in 14 | () 15 | -------------------------------------------------------------------------------- /code/front-end/html/index_attributes.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Index of class attributes 11 | 12 | 13 |
 Up 14 |  
15 |

Index of class attributes

16 | 17 |
18 | 19 | -------------------------------------------------------------------------------- /code/front-end/html/index_class_types.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Index of class types 11 | 12 | 13 |
 Up 14 |  
15 |

Index of class types

16 | 17 |
18 | 19 | -------------------------------------------------------------------------------- /code/front-end/html/index_classes.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Index of classes 11 | 12 | 13 |
 Up 14 |  
15 |

Index of classes

16 | 17 |
18 | 19 | -------------------------------------------------------------------------------- /code/front-end/html/index_exceptions.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Index of exceptions 11 | 12 | 13 |
 Up 14 |  
15 |

Index of exceptions

16 | 17 | 18 | 19 | 23 |

M
My_exception [Doc]
20 | Comment for exception My_exception. 21 |
22 |
24 | 25 | -------------------------------------------------------------------------------- /code/front-end/html/index_methods.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Index of class methods 11 | 12 | 13 |
 Up 14 |  
15 |

Index of class methods

16 | 17 |
18 | 19 | -------------------------------------------------------------------------------- /code/front-end/html/index_module_types.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Index of module types 11 | 12 | 13 |
 Up 14 |  
15 |

Index of module types

16 | 17 |
18 | 19 | -------------------------------------------------------------------------------- /code/front-end/html/index_modules.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Index of modules 11 | 12 | 13 |
 Up 14 |  
15 |

Index of modules

16 | 17 | 18 | 19 | 24 |

D
Doc
20 | example.ml: The first special comment of the file is the comment 21 | associated with the whole module. 22 |
23 |
25 | 26 | -------------------------------------------------------------------------------- /code/front-end/html/index_types.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Index of types 11 | 12 | 13 |
 Up 14 |  
15 |

Index of types

16 | 17 | 18 | 19 | 23 |

W
weather [Doc]
20 | Comment for type weather 21 |
22 |
24 | 25 | -------------------------------------------------------------------------------- /code/front-end/html/index_values.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | Index of values 11 | 12 | 13 |
 Up 14 |  
15 |

Index of values

16 | 17 | 18 | 19 | 23 |

W
what_is_the_weather_in [Doc]
20 | Find the current weather for a country 21 |
22 |
24 | 25 | -------------------------------------------------------------------------------- /code/front-end/html/type_Doc.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Doc 10 | 11 | 12 | sig  end -------------------------------------------------------------------------------- /code/front-end/inconsistent_compilation_units.rawsh: -------------------------------------------------------------------------------- 1 | $ ocamlc -c foo.ml 2 | File "foo.ml", line 1, characters 0-1: 3 | Error: The files /home/build/bar.cmi 4 | and /usr/lib/ocaml/map.cmi make inconsistent assumptions 5 | over interface Map 6 | -------------------------------------------------------------------------------- /code/front-end/indent_follow_on_function.sh: -------------------------------------------------------------------------------- 1 | ocp-indent follow_on_function.ml 2 | -------------------------------------------------------------------------------- /code/front-end/indent_follow_on_function_fixed.sh: -------------------------------------------------------------------------------- 1 | ocp-indent follow_on_function_fixed.ml 2 | -------------------------------------------------------------------------------- /code/front-end/infer_typedef.sh: -------------------------------------------------------------------------------- 1 | ocamlc -i typedef.ml 2 | -------------------------------------------------------------------------------- /code/front-end/install_ocp_index.rawsh: -------------------------------------------------------------------------------- 1 | $ opam install ocp-index 2 | $ ocp-index 3 | -------------------------------------------------------------------------------- /code/front-end/let_notunit.ml: -------------------------------------------------------------------------------- 1 | let (_:some_type) = 2 | let () = ignore ( : some_type) 3 | )(* if the expression returns a unit Deferred.t *) 4 | let () = don't_wait_for ( 5 | -------------------------------------------------------------------------------- /code/front-end/let_unit.syntax: -------------------------------------------------------------------------------- 1 | let () = 2 | -------------------------------------------------------------------------------- /code/front-end/man/man3/My_exception.3o: -------------------------------------------------------------------------------- 1 | .TH "My_exception" 3 2013-07-23 OCamldoc "" 2 | .SH NAME 3 | My_exception \- all My_exception elements 4 | 5 | 6 | .SH Module Doc 7 | 8 | .I exception My_exception 9 | .B of 10 | .B (int -> int) * int 11 | 12 | .sp 13 | Comment for exception My_exception\&. 14 | .sp 15 | 16 | .sp 17 | -------------------------------------------------------------------------------- /code/front-end/man/man3/Rain.3o: -------------------------------------------------------------------------------- 1 | .TH "Rain" 3 2013-07-23 OCamldoc "" 2 | .SH NAME 3 | Rain \- all Rain elements 4 | 5 | -------------------------------------------------------------------------------- /code/front-end/man/man3/Sun.3o: -------------------------------------------------------------------------------- 1 | .TH "Sun" 3 2013-07-23 OCamldoc "" 2 | .SH NAME 3 | Sun \- all Sun elements 4 | 5 | -------------------------------------------------------------------------------- /code/front-end/man/man3/weather.3o: -------------------------------------------------------------------------------- 1 | .TH "weather" 3 2013-07-23 OCamldoc "" 2 | .SH NAME 3 | weather \- all weather elements 4 | 5 | 6 | .SH Module Doc 7 | .I type weather 8 | = 9 | | Rain 10 | .B of 11 | .B int 12 | .I " " 13 | (* The comment for construtor Rain *) 14 | | Sun (* The comment for constructor Sun *) 15 | 16 | .sp 17 | Comment for type 18 | .B weather 19 | 20 | .sp 21 | 22 | .sp 23 | -------------------------------------------------------------------------------- /code/front-end/man/man3/what_is_the_weather_in.3o: -------------------------------------------------------------------------------- 1 | .TH "what_is_the_weather_in" 3 2013-07-23 OCamldoc "" 2 | .SH NAME 3 | what_is_the_weather_in \- all what_is_the_weather_in elements 4 | 5 | 6 | .SH Module Doc 7 | 8 | .I val what_is_the_weather_in 9 | : 10 | .B [< `California | `Cambridge | `New_york ] -> weather 11 | .sp 12 | Find the current weather for a country 13 | .sp 14 | .B "Author(s)" 15 | : 16 | Anil Madhavapeddy 17 | .sp 18 | 19 | .sp 20 | -------------------------------------------------------------------------------- /code/front-end/non_principal.ml: -------------------------------------------------------------------------------- 1 | type s = { foo: int; bar: unit } 2 | type t = { foo: int } 3 | 4 | let f x = 5 | x.bar; 6 | x.foo 7 | -------------------------------------------------------------------------------- /code/front-end/parsetree_typedef.sh: -------------------------------------------------------------------------------- 1 | ocamlc -dparsetree typedef.ml 2>&1 2 | -------------------------------------------------------------------------------- /code/front-end/pipeline.ascii: -------------------------------------------------------------------------------- 1 | Source code 2 | | 3 | | parsing and preprocessing 4 | | 5 | | camlp4 syntax extensions 6 | | 7 | v 8 | Parsetree (untyped AST) 9 | | 10 | | type inference and checking 11 | v 12 | Typedtree (type-annotated AST) 13 | | 14 | | pattern-matching compilation 15 | | elimination of modules and classes 16 | v 17 | Lambda 18 | / \ 19 | / \ closure conversion, inlining, uncurrying, 20 | v \ data representation strategy 21 | Bytecode \ 22 | | +-----+ 23 | | Cmm 24 | |ocamlrun | 25 | | | code generation 26 | | | assembly & linking 27 | v v 28 | Interpreted Compiled 29 | -------------------------------------------------------------------------------- /code/front-end/principal.ml: -------------------------------------------------------------------------------- 1 | type s = { foo: int; bar: unit } 2 | type t = { foo: int } 3 | 4 | let f (x:s) = 5 | x.bar; 6 | x.foo 7 | -------------------------------------------------------------------------------- /code/front-end/process_comparelib_interface.sh: -------------------------------------------------------------------------------- 1 | sh camlp4_dump.cmd comparelib_test.mli 2 | -------------------------------------------------------------------------------- /code/front-end/process_comparelib_test.sh: -------------------------------------------------------------------------------- 1 | sh camlp4_dump.cmd comparelib_test.ml 2 | -------------------------------------------------------------------------------- /code/front-end/short_paths_1.rawsh: -------------------------------------------------------------------------------- 1 | $ ocaml 2 | # List.map print_endline "" ;; 3 | Error: This expression has type string but an expression was expected of type 4 | string list 5 | -------------------------------------------------------------------------------- /code/front-end/short_paths_2.rawsh: -------------------------------------------------------------------------------- 1 | $ ocaml 2 | # open Core.Std ;; 3 | # List.map ~f:print_endline "" ;; 4 | Error: This expression has type string but an expression was expected of type 5 | 'a Core.Std.List.t = 'a list 6 | -------------------------------------------------------------------------------- /code/front-end/short_paths_3.rawsh: -------------------------------------------------------------------------------- 1 | $ ocaml -short-paths 2 | # open Core.Std;; 3 | # List.map ~f:print_endline "foo";; 4 | Error: This expression has type string but an expression was expected of type 5 | 'a list 6 | -------------------------------------------------------------------------------- /code/front-end/test.ml: -------------------------------------------------------------------------------- 1 | type t = Foo 2 | -------------------------------------------------------------------------------- /code/front-end/test.mli: -------------------------------------------------------------------------------- 1 | type t = Bar 2 | -------------------------------------------------------------------------------- /code/front-end/type_conv_example.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | 3 | type t = { 4 | foo: int; 5 | bar: string 6 | } with sexp, fields 7 | -------------------------------------------------------------------------------- /code/front-end/typedef.ml: -------------------------------------------------------------------------------- 1 | type t = Foo | Bar 2 | let v = Foo 3 | -------------------------------------------------------------------------------- /code/front-end/typedef_objinfo.sh: -------------------------------------------------------------------------------- 1 | ocamlc -c typedef.ml 2 | ocamlobjinfo typedef.cmi 3 | -------------------------------------------------------------------------------- /code/front-end/typedtree_typedef.sh: -------------------------------------------------------------------------------- 1 | ocamlc -dtypedtree typedef.ml 2>&1 2 | -------------------------------------------------------------------------------- /code/front-end/unused_var.ml: -------------------------------------------------------------------------------- 1 | let fn x y = 2 | let _z = x + y in 3 | () 4 | -------------------------------------------------------------------------------- /code/front-end/xbuild_type_conv_with_camlp4.sh: -------------------------------------------------------------------------------- 1 | ocamlfind ocamlc -c -syntax camlp4o -package sexplib.syntax -package fieldslib.syntax type_conv_example.ml 2 | -------------------------------------------------------------------------------- /code/functors/build_extended_fqueue.sh: -------------------------------------------------------------------------------- 1 | corebuild extended_fqueue.cmo 2 | -------------------------------------------------------------------------------- /code/functors/build_fqueue.sh: -------------------------------------------------------------------------------- 1 | corebuild fqueue.cmo 2 | -------------------------------------------------------------------------------- /code/functors/compare_example.ml: -------------------------------------------------------------------------------- 1 | compare x y < 0 (* x < y *) 2 | compare x y = 0 (* x = y *) 3 | compare x y > 0 (* x > y *) 4 | -------------------------------------------------------------------------------- /code/functors/destructive_sub.syntax: -------------------------------------------------------------------------------- 1 | with type := 2 | -------------------------------------------------------------------------------- /code/functors/extended_fqueue.ml: -------------------------------------------------------------------------------- 1 | include Fqueue 2 | include Foldable.Extend(Fqueue) 3 | -------------------------------------------------------------------------------- /code/functors/extended_fqueue.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | include (module type of Fqueue) with type 'a t := 'a t 3 | include Foldable.Extension with type 'a t := 'a t 4 | -------------------------------------------------------------------------------- /code/functors/fqueue.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type 'a t = 'a list * 'a list 4 | 5 | let empty = ([],[]) 6 | 7 | let enqueue (in_list, out_list) x = 8 | (x :: in_list,out_list) 9 | 10 | let dequeue (in_list, out_list) = 11 | match out_list with 12 | | hd :: tl -> Some (hd, (in_list, tl)) 13 | | [] -> 14 | match List.rev in_list with 15 | | [] -> None 16 | | hd :: tl -> Some (hd, ([], tl)) 17 | 18 | let fold (in_list, out_list) ~init ~f = 19 | let after_out = List.fold ~init ~f out_list in 20 | List.fold_right ~init:after_out ~f:(fun x acc -> f acc x) in_list 21 | -------------------------------------------------------------------------------- /code/functors/fqueue.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val empty : 'a t 4 | 5 | (** [enqueue el q] adds [el] to the back of [q] *) 6 | val enqueue : 'a t -> 'a -> 'a t 7 | 8 | (** [dequeue q] returns None if the [q] is empty, otherwise returns 9 | the first element of the queue and the remainder of the queue *) 10 | val dequeue : 'a t -> ('a * 'a t) option 11 | 12 | (** Folds over the queue, from front to back *) 13 | val fold : 'a t -> init:'acc -> f:('acc -> 'a -> 'acc) -> 'acc 14 | -------------------------------------------------------------------------------- /code/functors/main-15.rawscript: -------------------------------------------------------------------------------- 1 | # module Make_interval(Endpoint : Comparable) : Interval_intf = struct 2 | type endpoint = Endpoint.t 3 | type t = | Interval of Endpoint.t * Endpoint.t 4 | | Empty 5 | 6 | ... 7 | 8 | end ;; 9 | module Make_interval : functor (Endpoint : Comparable) -> Interval_intf 10 | -------------------------------------------------------------------------------- /code/functors/main-18.rawscript: -------------------------------------------------------------------------------- 1 | # module Make_interval(Endpoint : Comparable) 2 | : (Interval_intf with type endpoint = Endpoint.t) 3 | = struct 4 | 5 | type endpoint = Endpoint.t 6 | type t = | Interval of Endpoint.t * Endpoint.t 7 | | Empty 8 | 9 | ... 10 | 11 | end ;; 12 | module Make_interval : 13 | functor (Endpoint : Comparable) -> 14 | sig 15 | type t 16 | type endpoint = Endpoint.t 17 | val create : endpoint -> endpoint -> t 18 | val is_empty : t -> bool 19 | val contains : t -> endpoint -> bool 20 | val intersect : t -> t -> t 21 | end 22 | -------------------------------------------------------------------------------- /code/functors/main-21.rawscript: -------------------------------------------------------------------------------- 1 | # module Make_interval(Endpoint : Comparable) 2 | : Interval_intf with type endpoint := Endpoint.t = 3 | struct 4 | 5 | type t = | Interval of Endpoint.t * Endpoint.t 6 | | Empty 7 | 8 | ... 9 | 10 | end ;; 11 | module Make_interval : 12 | functor (Endpoint : Comparable) -> 13 | sig 14 | type t 15 | val create : Endpoint.t -> Endpoint.t -> t 16 | val is_empty : t -> bool 17 | val contains : t -> Endpoint.t -> bool 18 | val intersect : t -> t -> t 19 | end 20 | -------------------------------------------------------------------------------- /code/functors/main-25.rawscript: -------------------------------------------------------------------------------- 1 | # module Make_interval(Endpoint : Comparable) 2 | : (Interval_intf with type endpoint := Endpoint.t) = struct 3 | 4 | type t = | Interval of Endpoint.t * Endpoint.t 5 | | Empty 6 | with sexp 7 | 8 | ... 9 | 10 | end ;; 11 | Characters 136-146: 12 | Error: Unbound value Endpoint.t_of_sexp 13 | -------------------------------------------------------------------------------- /code/functors/multi_sharing_constraint.syntax: -------------------------------------------------------------------------------- 1 | with type = and = 2 | -------------------------------------------------------------------------------- /code/functors/sexpable.ml: -------------------------------------------------------------------------------- 1 | module type Sexpable = sig 2 | type t 3 | val sexp_of_t : t -> Sexp.t 4 | val t_of_sexp : Sexp.t -> t 5 | end 6 | -------------------------------------------------------------------------------- /code/functors/sharing_constraint.syntax: -------------------------------------------------------------------------------- 1 | with type = 2 | -------------------------------------------------------------------------------- /code/gc/barrier_bench.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | open Core_bench.Std 3 | 4 | type t1 = { mutable iters1: int; mutable count1: float } 5 | type t2 = { iters2: int; count2: float } 6 | 7 | let rec test_mutable t1 = 8 | match t1.iters1 with 9 | |0 -> () 10 | |_ -> 11 | t1.iters1 <- t1.iters1 - 1; 12 | t1.count1 <- t1.count1 +. 1.0; 13 | test_mutable t1 14 | 15 | let rec test_immutable t2 = 16 | match t2.iters2 with 17 | |0 -> () 18 | |n -> 19 | let iters2 = n - 1 in 20 | let count2 = t2.count2 +. 1.0 in 21 | test_immutable { iters2; count2 } 22 | 23 | let () = 24 | let iters = 1000000 in 25 | let tests = [ 26 | Bench.Test.create ~name:"mutable" 27 | (fun () -> test_mutable { iters1=iters; count1=0.0 }); 28 | Bench.Test.create ~name:"immutable" 29 | (fun () -> test_immutable { iters2=iters; count2=0.0 }) 30 | ] in 31 | Bench.make_command tests |> Command.run 32 | -------------------------------------------------------------------------------- /code/gc/minor_heap.ascii: -------------------------------------------------------------------------------- 1 | <---- size ----> 2 | base --- start ---------------- end 3 | limit ptr <------ 4 | blocks 5 | -------------------------------------------------------------------------------- /code/gc/run_barrier_bench.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg core_bench barrier_bench.native 2 | ./barrier_bench.native -ascii alloc 3 | -------------------------------------------------------------------------------- /code/gc/run_finalizer.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg async finalizer.native 2 | ./finalizer.native 3 | -------------------------------------------------------------------------------- /code/gc/show_barrier_bench_help.sh: -------------------------------------------------------------------------------- 1 | ./barrier_bench.native -help 2 | -------------------------------------------------------------------------------- /code/gc/tune.topscript: -------------------------------------------------------------------------------- 1 | let c = Gc.get () ;; 2 | Gc.tune ~minor_heap_size:(262144 * 2) () ;; 3 | #part 1 4 | Gc.tune ~major_heap_increment:(1000448 * 4) () ;; 5 | #part 2 6 | Gc.major_slice 0 ;; 7 | Gc.full_major () ;; 8 | #part 3 9 | Gc.tune ~max_overhead:0 () ;; 10 | -------------------------------------------------------------------------------- /code/guided-tour/build_sum.sh: -------------------------------------------------------------------------------- 1 | corebuild sum.native 2 | -------------------------------------------------------------------------------- /code/guided-tour/local_let.topscript: -------------------------------------------------------------------------------- 1 | let x = 7 in 2 | x + x 3 | ;; 4 | #part 1 5 | x;; 6 | #part 2 7 | let x = 7 in 8 | let y = x * x in 9 | x + y 10 | ;; 11 | -------------------------------------------------------------------------------- /code/guided-tour/recursion.ml: -------------------------------------------------------------------------------- 1 | sum [1;2;3] 2 | = 1 + sum [2;3] 3 | = 1 + (2 + sum [3]) 4 | = 1 + (2 + (3 + sum [])) 5 | = 1 + (2 + (3 + 0)) 6 | = 1 + (2 + 3) 7 | = 1 + 5 8 | = 6 9 | -------------------------------------------------------------------------------- /code/guided-tour/run_sum.sh: -------------------------------------------------------------------------------- 1 | ./sum.native 2 | -------------------------------------------------------------------------------- /code/guided-tour/sum.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let rec read_and_accumulate accum = 4 | let line = In_channel.input_line In_channel.stdin in 5 | match line with 6 | | None -> accum 7 | | Some x -> read_and_accumulate (accum +. Float.of_string x) 8 | 9 | let () = 10 | printf "Total: %F\n" (read_and_accumulate 0.) 11 | -------------------------------------------------------------------------------- /code/guided-tour/sum.rawsh: -------------------------------------------------------------------------------- 1 | $ ./sum.native 2 | 1 3 | 2 4 | 3 5 | 94.5 6 | Total: 100.5 7 | -------------------------------------------------------------------------------- /code/imperative-programming/.gitignore: -------------------------------------------------------------------------------- 1 | numbers.txt 2 | -------------------------------------------------------------------------------- /code/imperative-programming/array-get.syntax: -------------------------------------------------------------------------------- 1 | .() 2 | -------------------------------------------------------------------------------- /code/imperative-programming/array-set.syntax: -------------------------------------------------------------------------------- 1 | .() <- 2 | -------------------------------------------------------------------------------- /code/imperative-programming/bigarray.syntax: -------------------------------------------------------------------------------- 1 | .{} 2 | .{} <- 3 | -------------------------------------------------------------------------------- /code/imperative-programming/build_all.sh: -------------------------------------------------------------------------------- 1 | corebuild dictionary.cmo 2 | corebuild dlist.cmo 3 | corebuild time_converter.byte 4 | corebuild time_converter2.byte 5 | -------------------------------------------------------------------------------- /code/imperative-programming/dictionary.mli: -------------------------------------------------------------------------------- 1 | (* part 1 *) 2 | (* file: dictionary.mli *) 3 | open Core.Std 4 | 5 | type ('a, 'b) t 6 | 7 | val create : unit -> ('a, 'b) t 8 | val length : ('a, 'b) t -> int 9 | val add : ('a, 'b) t -> key:'a -> data:'b -> unit 10 | val find : ('a, 'b) t -> 'a -> 'b option 11 | val iter : ('a, 'b) t -> f:(key:'a -> data:'b -> unit) -> unit 12 | val remove : ('a, 'b) t -> 'a -> unit 13 | -------------------------------------------------------------------------------- /code/imperative-programming/dlist.mli: -------------------------------------------------------------------------------- 1 | (* file: dlist.mli *) 2 | open Core.Std 3 | 4 | type 'a t 5 | type 'a element 6 | 7 | (** Basic list operations *) 8 | val create : unit -> 'a t 9 | val is_empty : 'a t -> bool 10 | 11 | (** Navigation using [element]s *) 12 | val first : 'a t -> 'a element option 13 | val next : 'a element -> 'a element option 14 | val prev : 'a element -> 'a element option 15 | val value : 'a element -> 'a 16 | 17 | (** Whole-data-structure iteration *) 18 | val iter : 'a t -> f:('a -> unit) -> unit 19 | val find_el : 'a t -> f:('a -> bool) -> 'a element option 20 | 21 | (** Mutation *) 22 | val insert_first : 'a t -> 'a -> 'a element 23 | val insert_after : 'a element -> 'a -> 'a element 24 | val remove : 'a t -> 'a element -> unit 25 | -------------------------------------------------------------------------------- /code/imperative-programming/edit_distance.ascii: -------------------------------------------------------------------------------- 1 | edit_distance "OCam" "ocaml" 2 | edit_distance "OCaml" "ocam" 3 | edit_distance "OCam" "ocam" 4 | -------------------------------------------------------------------------------- /code/imperative-programming/edit_distance2.ascii: -------------------------------------------------------------------------------- 1 | edit_distance "OCam" "ocaml" 2 | edit_distance "OCa" "ocaml" 3 | edit_distance "OCam" "ocam" 4 | edit_distance "OCa" "ocam" 5 | edit_distance "OCaml" "ocam" 6 | edit_distance "OCam" "ocam" 7 | edit_distance "OCaml" "oca" 8 | edit_distance "OCam" "oca" 9 | edit_distance "OCam" "ocam" 10 | edit_distance "OCa" "ocam" 11 | edit_distance "OCam" "oca" 12 | edit_distance "OCa" "oca" 13 | -------------------------------------------------------------------------------- /code/imperative-programming/examples.topscript: -------------------------------------------------------------------------------- 1 | 1;; 2 | #part 1 3 | List.find_map;; 4 | #part 2 5 | let rec endless_loop = 1 :: 2 :: 3 :: endless_loop;; 6 | -------------------------------------------------------------------------------- /code/imperative-programming/file.topscript: -------------------------------------------------------------------------------- 1 | 1;; 2 | #part 1 3 | let create_number_file filename numbers = 4 | let outc = Out_channel.create filename in 5 | List.iter numbers ~f:(fun x -> fprintf outc "%d\n" x); 6 | Out_channel.close outc 7 | ;; 8 | let sum_file filename = 9 | let file = In_channel.create filename in 10 | let numbers = List.map ~f:Int.of_string (In_channel.input_lines file) in 11 | let sum = List.fold ~init:0 ~f:(+) numbers in 12 | In_channel.close file; 13 | sum 14 | ;; 15 | create_number_file "numbers.txt" [1;2;3;4;5];; 16 | sum_file "numbers.txt";; 17 | #part 2 18 | sum_file "/etc/hosts";; 19 | #part 3 20 | for i = 1 to 10000 do try ignore (sum_file "/etc/hosts") with _ -> () done;; 21 | sum_file "numbers.txt";; 22 | -------------------------------------------------------------------------------- /code/imperative-programming/file2.topscript: -------------------------------------------------------------------------------- 1 | 1;; 2 | #part 1 3 | let sum_file filename = 4 | let file = In_channel.create filename in 5 | protect ~f:(fun () -> 6 | let numbers = List.map ~f:Int.of_string (In_channel.input_lines file) in 7 | List.fold ~init:0 ~f:(+) numbers) 8 | ~finally:(fun () -> In_channel.close file) 9 | ;; 10 | #part 2 11 | for i = 1 to 10000 do try ignore (sum_file "/etc/hosts") with _ -> () done;; 12 | sum_file "numbers.txt";; 13 | #part 3 14 | let sum_file filename = 15 | In_channel.with_file filename ~f:(fun file -> 16 | let numbers = List.map ~f:Int.of_string (In_channel.input_lines file) in 17 | List.fold ~init:0 ~f:(+) numbers) 18 | ;; 19 | #part 4 20 | let sum_file filename = 21 | In_channel.with_file filename ~f:(fun file -> 22 | In_channel.fold_lines file ~init:0 ~f:(fun sum line -> 23 | sum + Int.of_string line)) 24 | ;; 25 | -------------------------------------------------------------------------------- /code/imperative-programming/for.topscript: -------------------------------------------------------------------------------- 1 | 1;; 2 | #part 1 3 | for i = 0 to 3 do printf "i = %d\n" i done;; 4 | #part 2 5 | for i = 3 downto 0 do printf "i = %d\n" i done;; 6 | #part 3 7 | let rev_inplace ar = 8 | let i = ref 0 in 9 | let j = ref (Array.length ar - 1) in 10 | (* terminate when the upper and lower indices meet *) 11 | while !i < !j do 12 | (* swap the two elements *) 13 | let tmp = ar.(!i) in 14 | ar.(!i) <- ar.(!j); 15 | ar.(!j) <- tmp; 16 | (* bump the indices *) 17 | incr i; 18 | decr j 19 | done 20 | ;; 21 | let nums = [|1;2;3;4;5|];; 22 | rev_inplace nums;; 23 | nums;; 24 | -------------------------------------------------------------------------------- /code/imperative-programming/lazy.topscript: -------------------------------------------------------------------------------- 1 | 1;; 2 | #part 1 3 | let v = lazy (print_string "performing lazy computation\n"; sqrt 16.);; 4 | Lazy.force v;; 5 | Lazy.force v;; 6 | #part 2 7 | type 'a lazy_state = 8 | | Delayed of (unit -> 'a) 9 | | Value of 'a 10 | | Exn of exn 11 | ;; 12 | #part 3 13 | let create_lazy f = ref (Delayed f);; 14 | let v = create_lazy 15 | (fun () -> print_string "performing lazy computation\n"; sqrt 16.);; 16 | #part 4 17 | let force v = 18 | match !v with 19 | | Value x -> x 20 | | Exn e -> raise e 21 | | Delayed f -> 22 | try 23 | let x = f () in 24 | v := Value x; 25 | x 26 | with exn -> 27 | v := Exn exn; 28 | raise exn 29 | ;; 30 | #part 5 31 | force v;; 32 | force v;; 33 | 34 | 35 | -------------------------------------------------------------------------------- /code/imperative-programming/let-unit.syntax: -------------------------------------------------------------------------------- 1 | let () = in 2 | let () = in 3 | ... 4 | 5 | -------------------------------------------------------------------------------- /code/imperative-programming/let_rec.ml: -------------------------------------------------------------------------------- 1 | let rec x = x + 1 2 | -------------------------------------------------------------------------------- /code/imperative-programming/letrec.topscript: -------------------------------------------------------------------------------- 1 | let time f = 2 | let start = Time.now () in 3 | let x = f () in 4 | let stop = Time.now () in 5 | printf "Time: %s\n" (Time.Span.to_string (Time.diff stop start)); 6 | x ;; 7 | let memoize f = 8 | let table = Hashtbl.Poly.create () in 9 | (fun x -> 10 | match Hashtbl.find table x with 11 | | Some y -> y 12 | | None -> 13 | let y = f x in 14 | Hashtbl.add_exn table ~key:x ~data:y; 15 | y 16 | );; 17 | #part 1 18 | let memo_rec f_norec = 19 | let rec f = memoize (fun x -> f_norec f x) in 20 | f 21 | ;; 22 | #part 2 23 | let rec x = lazy (Lazy.force x + 1);; 24 | #part 3 25 | Lazy.force x;; 26 | #part 4 27 | let fib_norec fib i = 28 | if i <= 1 then i 29 | else fib (i - 1) + fib (i - 2) ;; 30 | #part 5 31 | let lazy_memo_rec f_norec x = 32 | let rec f = lazy (memoize (fun x -> f_norec (Lazy.force f) x)) in 33 | (Lazy.force f) x 34 | ;; 35 | time (fun () -> lazy_memo_rec fib_norec 40);; 36 | 37 | 38 | 39 | -------------------------------------------------------------------------------- /code/imperative-programming/order.topscript: -------------------------------------------------------------------------------- 1 | 1;; 2 | #part 1 3 | let x = sin 120. in 4 | let y = sin 75. in 5 | let z = sin 128. in 6 | List.exists ~f:(fun x -> x < 0.) [x;y;z] 7 | ;; 8 | #part 2 9 | let x = lazy (sin 120.) in 10 | let y = lazy (sin 75.) in 11 | let z = lazy (sin 128.) in 12 | List.exists ~f:(fun x -> Lazy.force x < 0.) [x;y;z] 13 | ;; 14 | #part 3 15 | let x = lazy (printf "1\n"; sin 120.) in 16 | let y = lazy (printf "2\n"; sin 75.) in 17 | let z = lazy (printf "3\n"; sin 128.) in 18 | List.exists ~f:(fun x -> Lazy.force x < 0.) [x;y;z] 19 | ;; 20 | #part 4 21 | List.exists ~f:(fun x -> x < 0.) 22 | [ (printf "1\n"; sin 120.); 23 | (printf "2\n"; sin 75.); 24 | (printf "3\n"; sin 128.); ] 25 | ;; 26 | -------------------------------------------------------------------------------- /code/imperative-programming/printf.topscript: -------------------------------------------------------------------------------- 1 | open Printf 2 | 1;; 3 | #part 1 4 | printf "%i is an integer, %F is a float, \"%s\" is a string\n" 5 | 3 4.5 "five";; 6 | #part 2 7 | printf "An integer: %i\n" 4.5;; 8 | #part 3 9 | let fmt = "%i is an integer, %F is a float, \"%s\" is a string\n";; 10 | printf fmt 3 4.5 "five";; 11 | #part 4 12 | let fmt : ('a, 'b, 'c) format = 13 | "%i is an integer, %F is a float, \"%s\" is a string\n";; 14 | #part 5 15 | printf fmt 3 4.5 "five";; 16 | 17 | -------------------------------------------------------------------------------- /code/imperative-programming/ref.topscript: -------------------------------------------------------------------------------- 1 | 1;; 2 | #part 1 3 | type 'a ref = { mutable contents : 'a };; 4 | #part 2 5 | let ref x = { contents = x };; 6 | let (!) r = r.contents;; 7 | let (:=) r x = r.contents <- x;; 8 | #part 3 9 | let x = ref 1;; 10 | !x;; 11 | x := !x + 1;; 12 | !x;; 13 | -------------------------------------------------------------------------------- /code/imperative-programming/remember_type.ml: -------------------------------------------------------------------------------- 1 | val remember : '_a -> '_a = 2 | -------------------------------------------------------------------------------- /code/imperative-programming/semicolon-syntax.syntax: -------------------------------------------------------------------------------- 1 | ; 2 | ; 3 | ... 4 | 5 | -------------------------------------------------------------------------------- /code/imperative-programming/semicolon.syntax: -------------------------------------------------------------------------------- 1 | ; 2 | ; 3 | ... 4 | 5 | -------------------------------------------------------------------------------- /code/imperative-programming/string.syntax: -------------------------------------------------------------------------------- 1 | .[] 2 | .[] <- 3 | -------------------------------------------------------------------------------- /code/imperative-programming/time_converter.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let () = 4 | Out_channel.output_string stdout "Pick a timezone: "; 5 | Out_channel.flush stdout; 6 | match In_channel.input_line stdin with 7 | | None -> failwith "No timezone provided" 8 | | Some zone_string -> 9 | let zone = Zone.find_exn zone_string in 10 | let time_string = Time.to_string_abs (Time.now ()) ~zone in 11 | Out_channel.output_string stdout 12 | (String.concat 13 | ["The time in ";Zone.to_string zone;" is ";time_string;".\n"]); 14 | Out_channel.flush stdout 15 | 16 | -------------------------------------------------------------------------------- /code/imperative-programming/time_converter.rawsh: -------------------------------------------------------------------------------- 1 | $ corebuild time_converter.byte 2 | $ ./time_converter.byte 3 | Pick a timezone: 4 | -------------------------------------------------------------------------------- /code/imperative-programming/time_converter2.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let () = 4 | printf "Pick a timezone: %!"; 5 | match In_channel.input_line stdin with 6 | | None -> failwith "No timezone provided" 7 | | Some zone_string -> 8 | let zone = Time.Zone.find_exn zone_string in 9 | let time_string = Time.to_string_abs (Time.now ()) ~zone in 10 | printf "The time in %s is %s.\n%!" (Time.Zone.to_string zone) time_string 11 | -------------------------------------------------------------------------------- /code/imperative-programming/time_converter2.rawsh: -------------------------------------------------------------------------------- 1 | Pick a timezone: Europe/London 2 | The time in Europe/London is 2013-08-15 00:03:10.666220+01:00. 3 | -------------------------------------------------------------------------------- /code/imperative-programming/value_restriction-13.rawscript: -------------------------------------------------------------------------------- 1 | # module Concat_list : sig 2 | type 'a t 3 | val empty : 'a t 4 | val singleton : 'a -> 'a t 5 | val concat : 'a t -> 'a t -> 'a t (* constant time *) 6 | val to_list : 'a t -> 'a list (* linear time *) 7 | end = struct 8 | 9 | type 'a t = Empty | Singleton of 'a | Concat of 'a t * 'a t 10 | 11 | ... 12 | 13 | end;; 14 | module Concat_list : 15 | sig 16 | type 'a t 17 | val empty : 'a t 18 | val singleton : 'a -> 'a t 19 | val concat : 'a t -> 'a t -> 'a t 20 | val to_list : 'a t -> 'a list 21 | end 22 | -------------------------------------------------------------------------------- /code/imperative-programming/weak.topscript: -------------------------------------------------------------------------------- 1 | 1;; 2 | #part 1 3 | let remember = 4 | let cache = ref None in 5 | (fun x -> 6 | match !cache with 7 | | Some y -> y 8 | | None -> cache := Some x; x) 9 | ;; 10 | #part 2 11 | let identity x = x;; 12 | identity 3;; 13 | identity "five";; 14 | #part 3 15 | let remember_three () = remember 3;; 16 | remember;; 17 | remember "avocado";; 18 | -------------------------------------------------------------------------------- /code/installation/arch_install.rawsh: -------------------------------------------------------------------------------- 1 | # pacman -Sy ocaml 2 | -------------------------------------------------------------------------------- /code/installation/arch_opam.rawsh: -------------------------------------------------------------------------------- 1 | $ sudo pacman -Sy base-devel 2 | $ wget https://aur.archlinux.org/packages/op/opam/opam.tar.gz 3 | $ tar -xvf opam.tar.gz && cd opam 4 | $ makepkg 5 | $ sudo pacman -U opam-.tar.gz 6 | -------------------------------------------------------------------------------- /code/installation/brew_install.rawsh: -------------------------------------------------------------------------------- 1 | $ brew update 2 | $ brew install ocaml 3 | $ brew install pcre 4 | -------------------------------------------------------------------------------- /code/installation/brew_opam_install.rawsh: -------------------------------------------------------------------------------- 1 | $ brew update 2 | $ brew install opam 3 | -------------------------------------------------------------------------------- /code/installation/debian_apt.rawsh: -------------------------------------------------------------------------------- 1 | # apt-get install \ 2 | ocaml ocaml-native-compilers camlp4-extra \ 3 | git libpcre3-dev curl build-essential m4 4 | -------------------------------------------------------------------------------- /code/installation/debian_apt_opam.rawsh: -------------------------------------------------------------------------------- 1 | # apt-get update 2 | # apt-get -t unstable install opam 3 | -------------------------------------------------------------------------------- /code/installation/emacsrc.scm: -------------------------------------------------------------------------------- 1 | (autoload 'utop "utop" "Toplevel for OCaml" t) 2 | -------------------------------------------------------------------------------- /code/installation/fedora_install.rawsh: -------------------------------------------------------------------------------- 1 | # yum install ocaml 2 | # yum install ocaml-camlp4-devel 3 | # yum install pcre-devel 4 | -------------------------------------------------------------------------------- /code/installation/macports_install.rawsh: -------------------------------------------------------------------------------- 1 | $ sudo port install ocaml 2 | $ sudo port install ocaml-pcre 3 | -------------------------------------------------------------------------------- /code/installation/macports_opam_install.rawsh: -------------------------------------------------------------------------------- 1 | $ sudo port install opam 2 | -------------------------------------------------------------------------------- /code/installation/ocaml_src_install.rawsh: -------------------------------------------------------------------------------- 1 | $ curl -OL https://github.com/ocaml/ocaml/archive/4.01.tar.gz 2 | $ tar -zxvf 4.01.tar.gz 3 | $ cd ocaml-4.01 4 | $ ./configure 5 | $ make world world.opt 6 | $ sudo make install 7 | -------------------------------------------------------------------------------- /code/installation/ocaml_user_conf.rawsh: -------------------------------------------------------------------------------- 1 | $ ./configure -prefix $HOME/my-ocaml 2 | -------------------------------------------------------------------------------- /code/installation/opam_eval.rawsh: -------------------------------------------------------------------------------- 1 | $ eval `opam config env` 2 | -------------------------------------------------------------------------------- /code/installation/opam_init.rawsh: -------------------------------------------------------------------------------- 1 | $ opam init 2 | <...> 3 | =-=-=-= Configuring OPAM =-=-=-= 4 | Do you want to update your configuration to use OPAM ? [Y/n] y 5 | [1/4] Do you want to update your shell configuration file ? [default: ~/.profile] y 6 | [2/4] Do you want to update your ~/.ocamlinit ? [Y/n] y 7 | [3/4] Do you want to install the auto-complete scripts ? [Y/n] y 8 | [4/4] Do you want to install the `opam-switch-eval` script ? [Y/n] y 9 | User configuration: 10 | ~/.ocamlinit is already up-to-date. 11 | ~/.profile is already up-to-date. 12 | Gloabal configuration: 13 | Updating /opam-init/init.sh 14 | auto-completion : [true] 15 | opam-switch-eval: [true] 16 | Updating /opam-init/init.zsh 17 | auto-completion : [true] 18 | opam-switch-eval: [true] 19 | Updating /opam-init/init.csh 20 | auto-completion : [true] 21 | opam-switch-eval: [true] 22 | -------------------------------------------------------------------------------- /code/installation/opam_install.rawsh: -------------------------------------------------------------------------------- 1 | $ opam install core core_extended core_bench async 2 | -------------------------------------------------------------------------------- /code/installation/opam_install_utop.rawsh: -------------------------------------------------------------------------------- 1 | $ opam install utop 2 | -------------------------------------------------------------------------------- /code/installation/opam_list.rawsh: -------------------------------------------------------------------------------- 1 | $ opam list 2 | Installed packages for 4.01.0: 3 | async 109.38.00 Monadic concurrency library 4 | async_core 109.38.00 Monadic concurrency library 5 | async_extra 109.38.00 Monadic concurrency library 6 | <...> 7 | -------------------------------------------------------------------------------- /code/installation/opam_switch.rawsh: -------------------------------------------------------------------------------- 1 | $ opam switch 4.01.0dev+trunk 2 | $ eval `opam config env` 3 | -------------------------------------------------------------------------------- /code/installation/open_core.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | -------------------------------------------------------------------------------- /code/installation/show_ocamlinit.rawsh: -------------------------------------------------------------------------------- 1 | $ cat ~/.ocamlinit 2 | #use "topfind" 3 | #thread 4 | #camlp4o 5 | #require "core.top" 6 | #require "core.syntax" 7 | -------------------------------------------------------------------------------- /code/installation/ubuntu_opam_ppa.rawsh: -------------------------------------------------------------------------------- 1 | $ add-apt-repository ppa:avsm/ppa 2 | $ apt-get update 3 | $ apt-get install ocaml opam 4 | -------------------------------------------------------------------------------- /code/json/_tags: -------------------------------------------------------------------------------- 1 | true: -warn_32 2 | -------------------------------------------------------------------------------- /code/json/book.json: -------------------------------------------------------------------------------- 1 | { 2 | "title": "Real World OCaml", 3 | "tags" : [ "functional programming", "ocaml", "algorithms" ], 4 | "pages": 450, 5 | "authors": [ 6 | { "name": "Jason Hickey", "affiliation": "Google" }, 7 | { "name": "Anil Madhavapeddy", "affiliation": "Cambridge"}, 8 | { "name": "Yaron Minsky", "affiliation": "Jane Street"} 9 | ], 10 | "is_online": true 11 | } 12 | -------------------------------------------------------------------------------- /code/json/build_github_atd.sh: -------------------------------------------------------------------------------- 1 | atdgen -t github.atd 2 | atdgen -j github.atd 3 | ocamlfind ocamlc -package atd -i github_t.mli 4 | -------------------------------------------------------------------------------- /code/json/build_github_org.sh: -------------------------------------------------------------------------------- 1 | atdgen -t github_org.atd 2 | atdgen -j github_org.atd 3 | corebuild -pkg core_extended,yojson,atdgen github_org_info.native 4 | -------------------------------------------------------------------------------- /code/json/build_json.topscript: -------------------------------------------------------------------------------- 1 | #require "yojson" ;; 2 | open Core.Std ;; 3 | #part 1 4 | let person = `Assoc [ ("name", `String "Anil") ] ;; 5 | #part 2 6 | Yojson.Basic.pretty_to_string ;; 7 | #part 3 8 | Yojson.Basic.pretty_to_string person ;; 9 | Yojson.Basic.pretty_to_channel stdout person ;; 10 | #part 4 11 | let person = `Assoc ("name", `String "Anil");; 12 | Yojson.Basic.pretty_to_string person ;; 13 | #part 5 14 | let (person : Yojson.Basic.json) = 15 | `Assoc ("name", `String "Anil");; 16 | -------------------------------------------------------------------------------- /code/json/generate_github_org_json.sh: -------------------------------------------------------------------------------- 1 | atdgen -j github_org.atd 2 | cat github_org_j.mli 3 | -------------------------------------------------------------------------------- /code/json/generate_github_org_types.sh: -------------------------------------------------------------------------------- 1 | atdgen -t github_org.atd 2 | cat github_org_t.mli 3 | -------------------------------------------------------------------------------- /code/json/github.atd: -------------------------------------------------------------------------------- 1 | type scope = [ 2 | User 3 | | Public_repo 4 | | Repo 5 | | Repo_status 6 | | Delete_repo 7 | | Gist 8 | ] 9 | 10 | type app = { 11 | name: string; 12 | url: string; 13 | } 14 | 15 | type authorization_request = { 16 | scopes: scope list; 17 | note: string; 18 | } 19 | 20 | type authorization_response = { 21 | scopes: scope list; 22 | token: string; 23 | app: app; 24 | url: string; 25 | id: int; 26 | ?note: string option; 27 | ?note_url: string option; 28 | } 29 | -------------------------------------------------------------------------------- /code/json/github_j_excerpt.mli: -------------------------------------------------------------------------------- 1 | val string_of_authorization_request : 2 | ?len:int -> authorization_request -> string 3 | (** Serialize a value of type {!authorization_request} 4 | into a JSON string. 5 | @param len specifies the initial length 6 | of the buffer used internally. 7 | Default: 1024. *) 8 | 9 | val string_of_authorization_response : 10 | ?len:int -> authorization_response -> string 11 | (** Serialize a value of type {!authorization_response} 12 | into a JSON string. 13 | @param len specifies the initial length 14 | of the buffer used internally. 15 | Default: 1024. *) 16 | -------------------------------------------------------------------------------- /code/json/github_org.atd: -------------------------------------------------------------------------------- 1 | type org = { 2 | login: string; 3 | id: int; 4 | url: string; 5 | ?name: string option; 6 | ?blog: string option; 7 | ?email: string option; 8 | public_repos: int 9 | } 10 | -------------------------------------------------------------------------------- /code/json/github_org_info.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let print_org file () = 4 | let url = sprintf "https://api.github.com/orgs/%s" file in 5 | Core_extended.Shell.run_full "curl" [url] 6 | |> Github_org_j.org_of_string 7 | |> fun org -> 8 | let open Github_org_t in 9 | let name = Option.value ~default:"???" org.name in 10 | printf "%s (%d) with %d public repos\n" 11 | name org.id org.public_repos 12 | 13 | let () = 14 | Command.basic ~summary:"Print Github organization information" 15 | Command.Spec.(empty +> anon ("organization" %: string)) 16 | print_org 17 | |> Command.run 18 | -------------------------------------------------------------------------------- /code/json/github_org_j.mli: -------------------------------------------------------------------------------- 1 | (* Auto-generated from "github_org.atd" *) 2 | 3 | 4 | type org = Github_org_t.org = { 5 | login: string; 6 | id: int; 7 | url: string; 8 | name: string option; 9 | blog: string option; 10 | email: string option; 11 | public_repos: int 12 | } 13 | 14 | val write_org : 15 | Bi_outbuf.t -> org -> unit 16 | (** Output a JSON value of type {!org}. *) 17 | 18 | val string_of_org : 19 | ?len:int -> org -> string 20 | (** Serialize a value of type {!org} 21 | into a JSON string. 22 | @param len specifies the initial length 23 | of the buffer used internally. 24 | Default: 1024. *) 25 | 26 | val read_org : 27 | Yojson.Safe.lexer_state -> Lexing.lexbuf -> org 28 | (** Input JSON data of type {!org}. *) 29 | 30 | val org_of_string : 31 | string -> org 32 | (** Deserialize JSON data of type {!org}. *) 33 | 34 | -------------------------------------------------------------------------------- /code/json/github_org_t.ml: -------------------------------------------------------------------------------- 1 | (* Auto-generated from "github_org.atd" *) 2 | 3 | 4 | type org = { 5 | login: string; 6 | id: int; 7 | url: string; 8 | name: string option; 9 | blog: string option; 10 | email: string option; 11 | public_repos: int 12 | } 13 | -------------------------------------------------------------------------------- /code/json/github_org_t.mli: -------------------------------------------------------------------------------- 1 | (* Auto-generated from "github_org.atd" *) 2 | 3 | 4 | type org = { 5 | login: string; 6 | id: int; 7 | url: string; 8 | name: string option; 9 | blog: string option; 10 | email: string option; 11 | public_repos: int 12 | } 13 | -------------------------------------------------------------------------------- /code/json/github_t.ml: -------------------------------------------------------------------------------- 1 | (* Auto-generated from "github.atd" *) 2 | 3 | 4 | type scope = [ 5 | `User | `Public_repo | `Repo | `Repo_status | `Delete_repo | `Gist 6 | ] 7 | 8 | type app = { app_name (*atd name *): string; app_url (*atd url *): string } 9 | 10 | type authorization_request = { 11 | auth_req_scopes (*atd scopes *): scope list; 12 | auth_req_note (*atd note *): string 13 | } 14 | 15 | type authorization_response = { 16 | scopes: scope list; 17 | token: string; 18 | app: app; 19 | url: string; 20 | id: int; 21 | note: string option; 22 | note_url: string option 23 | } 24 | -------------------------------------------------------------------------------- /code/json/github_t.mli: -------------------------------------------------------------------------------- 1 | (* Auto-generated from "github.atd" *) 2 | 3 | 4 | type scope = [ 5 | `User | `Public_repo | `Repo | `Repo_status | `Delete_repo | `Gist 6 | ] 7 | 8 | type app = { app_name (*atd name *): string; app_url (*atd url *): string } 9 | 10 | type authorization_request = { 11 | auth_req_scopes (*atd scopes *): scope list; 12 | auth_req_note (*atd note *): string 13 | } 14 | 15 | type authorization_response = { 16 | scopes: scope list; 17 | token: string; 18 | app: app; 19 | url: string; 20 | id: int; 21 | note: string option; 22 | note_url: string option 23 | } 24 | -------------------------------------------------------------------------------- /code/json/install.topscript: -------------------------------------------------------------------------------- 1 | #require "yojson" ;; 2 | open Yojson ;; 3 | -------------------------------------------------------------------------------- /code/json/install_atdgen.rawsh: -------------------------------------------------------------------------------- 1 | $ opam install atdgen 2 | $ atdgen -version 3 | 1.2.3 4 | -------------------------------------------------------------------------------- /code/json/list_excerpt.mli: -------------------------------------------------------------------------------- 1 | val map : 'a list -> f:('a -> 'b) -> 'b list 2 | val fold : 'a list -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum 3 | (* part 1 *) 4 | val iter : 'a list -> f:('a -> unit) -> unit 5 | -------------------------------------------------------------------------------- /code/json/parse_book.topscript: -------------------------------------------------------------------------------- 1 | #require "yojson" ;; 2 | let json = Yojson.Basic.from_file "book.json" ;; 3 | #part 1 4 | open Yojson.Basic.Util ;; 5 | let title = json |> member "title" |> to_string ;; 6 | #part 2 7 | let tags = json |> member "tags" |> to_list |> filter_string ;; 8 | let pages = json |> member "pages" |> to_int ;; 9 | #part 3 10 | let is_online = json |> member "is_online" |> to_bool_option ;; 11 | let is_translated = json |> member "is_translated" |> to_bool_option ;; 12 | #part 4 13 | let authors = json |> member "authors" |> to_list ;; 14 | #part 5 15 | let names = 16 | json |> member "authors" |> to_list 17 | |> List.map ~f:(fun json -> member "name" json |> to_string) ;; 18 | -------------------------------------------------------------------------------- /code/json/read_json.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let () = 4 | (* Read JSON file into an OCaml string *) 5 | let buf = In_channel.read_all "book.json" in 6 | (* Use the string JSON constructor *) 7 | let json1 = Yojson.Basic.from_string buf in 8 | (* Use the file JSON constructor *) 9 | let json2 = Yojson.Basic.from_file "book.json" in 10 | (* Test that the two values are the same *) 11 | print_endline (if json1 = json2 then "OK" else "FAIL") 12 | -------------------------------------------------------------------------------- /code/json/run_github_org.sh: -------------------------------------------------------------------------------- 1 | ./github_org_info.native mirage 2 | ./github_org_info.native janestreet 3 | -------------------------------------------------------------------------------- /code/json/run_parse_book.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg yojson parse_book.native 2 | ./parse_book.native 3 | -------------------------------------------------------------------------------- /code/json/run_read_json.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg yojson read_json.native 2 | ./read_json.native 3 | -------------------------------------------------------------------------------- /code/json/yojson_basic_simple.mli: -------------------------------------------------------------------------------- 1 | val from_string : string -> json 2 | val from_file : string -> json 3 | val from_channel : in_channel -> json 4 | -------------------------------------------------------------------------------- /code/json/yojson_safe.mli: -------------------------------------------------------------------------------- 1 | type json = [ 2 | | `Assoc of (string * json) list 3 | | `Bool of bool 4 | | `Float of float 5 | | `Floatlit of string 6 | | `Int of int 7 | | `Intlit of string 8 | | `List of json list 9 | | `Null 10 | | `String of string 11 | | `Stringlit of string 12 | | `Tuple of json list 13 | | `Variant of string * json option 14 | ] 15 | 16 | (* part 1 *) 17 | val to_basic : json -> Yojson.Basic.json 18 | (** Tuples are converted to JSON arrays, Variants are converted to 19 | JSON strings or arrays of a string (constructor) and a json value 20 | (argument). Long integers are converted to JSON strings. 21 | Examples: 22 | 23 | `Tuple [ `Int 1; `Float 2.3 ] -> `List [ `Int 1; `Float 2.3 ] 24 | `Variant ("A", None) -> `String "A" 25 | `Variant ("B", Some x) -> `List [ `String "B", x ] 26 | `Intlit "12345678901234567890" -> `String "12345678901234567890" 27 | *) 28 | -------------------------------------------------------------------------------- /code/lists-and-patterns/example.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/realworldocaml/examples/32ea926861a0b728813a29b0e4cf20dd15eb486e/code/lists-and-patterns/example.ml -------------------------------------------------------------------------------- /code/lists-and-patterns/example.mli: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/realworldocaml/examples/32ea926861a0b728813a29b0e4cf20dd15eb486e/code/lists-and-patterns/example.mli -------------------------------------------------------------------------------- /code/lists-and-patterns/lists_layout.ascii: -------------------------------------------------------------------------------- 1 | +---+---+ +---+---+ +---+---+ 2 | | 1 | *---->| 2 | *---->| 3 | *---->|| 3 | +---+---+ +---+---+ +---+---+ 4 | -------------------------------------------------------------------------------- /code/maps-and-hash-tables/comparable.ml: -------------------------------------------------------------------------------- 1 | module type Comparable = sig 2 | type t 3 | val sexp_of_t : t -> Sexp.t 4 | val t_of_sexp : Sexp.t -> t 5 | val compare : t -> t -> int 6 | end 7 | -------------------------------------------------------------------------------- /code/maps-and-hash-tables/core_phys_equal.topscript: -------------------------------------------------------------------------------- 1 | open Core.Std ;; 2 | 1 == 2 ;; 3 | phys_equal 1 2 ;; 4 | -------------------------------------------------------------------------------- /code/maps-and-hash-tables/main-22.rawscript: -------------------------------------------------------------------------------- 1 | # module Foo_and_bar : sig 2 | type t = { foo: Int.Set.t; bar: string } 3 | include Comparable.S with type t := t 4 | end = struct 5 | module T = struct 6 | type t = { foo: Int.Set.t; bar: string } with sexp 7 | let compare t1 t2 = 8 | let c = Int.Set.compare t1.foo t2.foo in 9 | if c <> 0 then c else String.compare t1.bar t2.bar 10 | end 11 | include T 12 | include Comparable.Make(T) 13 | end;; 14 | module Foo_and_bar : 15 | sig 16 | type t = { foo : Int.Set.t; bar : string; } 17 | val ( >= ) : t -> t -> bool 18 | val ( <= ) : t -> t -> bool 19 | val ( = ) : t -> t -> bool 20 | 21 | ... 22 | 23 | end 24 | -------------------------------------------------------------------------------- /code/maps-and-hash-tables/main-23.rawscript: -------------------------------------------------------------------------------- 1 | # module Foo_and_bar : sig 2 | type t = { foo: Int.Set.t; bar: string } 3 | include Comparable.S with type t := t 4 | end = struct 5 | module T = struct 6 | type t = { foo: Int.Set.t; bar: string } with sexp, compare 7 | end 8 | include T 9 | include Comparable.Make(T) 10 | end;; 11 | module Foo_and_bar : 12 | sig 13 | type t = { foo : Int.Set.t; bar : string; } 14 | val ( >= ) : t -> t -> bool 15 | val ( <= ) : t -> t -> bool 16 | val ( = ) : t -> t -> bool 17 | 18 | ... 19 | 20 | end 21 | -------------------------------------------------------------------------------- /code/maps-and-hash-tables/main-24.rawscript: -------------------------------------------------------------------------------- 1 | # module Foo_and_bar : sig 2 | type t = { foo: int; bar: string } 3 | include Comparable.S with type t := t 4 | end = struct 5 | module T = struct 6 | type t = { foo: int; bar: string } with sexp 7 | end 8 | include T 9 | include Comparable.Poly(T) 10 | end;; 11 | module Foo_and_bar : 12 | sig 13 | type t = { foo : int; bar : string; } 14 | val ( >= ) : t -> t -> bool 15 | val ( <= ) : t -> t -> bool 16 | val ( = ) : t -> t -> bool 17 | 18 | ... 19 | 20 | end 21 | 22 | -------------------------------------------------------------------------------- /code/maps-and-hash-tables/main-30.rawscript: -------------------------------------------------------------------------------- 1 | # module Foo_and_bar : sig 2 | type t = { foo: int; bar: string } 3 | include Hashable.S with type t := t 4 | end = struct 5 | module T = struct 6 | type t = { foo: int; bar: string } with sexp, compare 7 | let hash t = 8 | (Int.hash t.foo) lxor (String.hash t.bar) 9 | end 10 | include T 11 | include Hashable.Make(T) 12 | end;; 13 | module Foo_and_bar : 14 | sig 15 | type t = { foo : int; bar : string; } 16 | module Hashable : sig type t = t end 17 | val hash : t -> int 18 | val compare : t -> t -> int 19 | val hashable : t Pooled_hashtbl.Hashable.t 20 | 21 | ... 22 | 23 | end 24 | -------------------------------------------------------------------------------- /code/maps-and-hash-tables/phys_equal.rawscript: -------------------------------------------------------------------------------- 1 | # type t1 = { foo1:int; bar1:t2 } and t2 = { foo2:int; bar2:t1 } ;; 2 | type t1 = { foo1 : int; bar1 : t2; } 3 | and t2 = { foo2 : int; bar2 : t1; } 4 | # let rec v1 = { foo1=1; bar1=v2 } and v2 = { foo2=2; bar2=v1 } ;; 5 | 6 | # v1 == v1;; 7 | - : bool = true 8 | # phys_equal v1 v1;; 9 | - : bool = true 10 | # v1 = v1 ;; 11 | 12 | -------------------------------------------------------------------------------- /code/maps-and-hash-tables/run_map_vs_hash.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg core_bench map_vs_hash.native 2 | ./map_vs_hash.native -ascii -clear-columns time speedup 3 | -------------------------------------------------------------------------------- /code/maps-and-hash-tables/run_map_vs_hash2.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg core_bench map_vs_hash2.native 2 | ./map_vs_hash2.native -ascii -clear-columns time speedup 3 | -------------------------------------------------------------------------------- /code/memory-repr/block.ascii: -------------------------------------------------------------------------------- 1 | +------------------------+---------+----------+----------+----------+---- 2 | | size of block in words | color | tag byte | value[0] | value[1] | ... 3 | +------------------------+---------+----------+----------+----------+---- 4 | <-either 22 or 54 bits-> <-2 bit-> <--8 bit--> 5 | -------------------------------------------------------------------------------- /code/memory-repr/custom_ops.c: -------------------------------------------------------------------------------- 1 | struct custom_operations { 2 | char *identifier; 3 | void (*finalize)(value v); 4 | int (*compare)(value v1, value v2); 5 | intnat (*hash)(value v); 6 | void (*serialize)(value v, 7 | /*out*/ uintnat * wsize_32 /*size in bytes*/, 8 | /*out*/ uintnat * wsize_64 /*size in bytes*/); 9 | uintnat (*deserialize)(void * dst); 10 | int (*compare_ext)(value v1, value v2); 11 | }; 12 | -------------------------------------------------------------------------------- /code/memory-repr/float_array_layout.ascii: -------------------------------------------------------------------------------- 1 | +---------+----------+----------- - - - - 2 | | header | float[0] | float[1] | .... 3 | +---------+----------+----------+- - - - - 4 | -------------------------------------------------------------------------------- /code/memory-repr/reprs.topscript: -------------------------------------------------------------------------------- 1 | Obj.is_block (Obj.repr (1,2,3)) ;; 2 | Obj.is_block (Obj.repr 1) ;; 3 | #part 1 4 | Obj.tag (Obj.repr 1.0) ;; 5 | Obj.double_tag ;; 6 | #part 2 7 | Obj.double_tag ;; 8 | Obj.double_array_tag ;; 9 | #part 3 10 | Obj.tag (Obj.repr [| 1.0; 2.0; 3.0 |]) ;; 11 | Obj.tag (Obj.repr (1.0, 2.0, 3.0) ) ;; 12 | Obj.double_field (Obj.repr [| 1.1; 2.2; 3.3 |]) 1 ;; 13 | Obj.double_field (Obj.repr 1.234) 0 ;; 14 | #part 4 15 | type t = Apple | Orange | Pear ;; 16 | ((Obj.magic (Obj.repr Apple)) : int) ;; 17 | ((Obj.magic (Obj.repr Pear)) : int) ;; 18 | Obj.is_block (Obj.repr Apple) ;; 19 | #part 5 20 | type t = Apple | Orange of int | Pear of string | Kiwi ;; 21 | Obj.is_block (Obj.repr (Orange 1234)) ;; 22 | Obj.tag (Obj.repr (Orange 1234)) ;; 23 | Obj.tag (Obj.repr (Pear "xyz")) ;; 24 | (Obj.magic (Obj.field (Obj.repr (Orange 1234)) 0) : int) ;; 25 | (Obj.magic (Obj.field (Obj.repr (Pear "xyz")) 0) : string) ;; 26 | #part 6 27 | Pa_type_conv.hash_variant "Foo" ;; 28 | (Obj.magic (Obj.repr `Foo) : int) ;; 29 | -------------------------------------------------------------------------------- /code/memory-repr/simple_record.topscript: -------------------------------------------------------------------------------- 1 | type t = { foo: int; bar: int } ;; 2 | let x = { foo = 13; bar = 14 } ;; 3 | -------------------------------------------------------------------------------- /code/memory-repr/string_block.ascii: -------------------------------------------------------------------------------- 1 | +---------------+----------------+--------+-----------+ 2 | | header | 'a' 'b' 'c' 'd' 'e' 'f' | '\O' '\1' | 3 | +---------------+----------------+--------+-----------+ 4 | L data L padding 5 | -------------------------------------------------------------------------------- /code/memory-repr/string_size_calc.ascii: -------------------------------------------------------------------------------- 1 | number_of_words_in_block * sizeof(word) - last_byte_of_block - 1 2 | -------------------------------------------------------------------------------- /code/memory-repr/tuple_layout.ascii: -------------------------------------------------------------------------------- 1 | +---------+----------+----------- - - - - 2 | | header | value[0] | value[1] | .... 3 | +---------+----------+----------+- - - - - 4 | -------------------------------------------------------------------------------- /code/objects/IsBarbell.java: -------------------------------------------------------------------------------- 1 | boolean IsBarbell(Shape[] s) { 2 | return s.length == 3 && (s[0] instanceof Circle) && 3 | (s[1] instanceof Line) && (s[2] instanceof Circle) && 4 | ((Circle) s[0]).radius() == ((Circle) s[2]).radius(); 5 | } 6 | -------------------------------------------------------------------------------- /code/objects/Shape.java: -------------------------------------------------------------------------------- 1 | String GetShapeName(Shape s) { 2 | if (s instanceof Square) { 3 | return "Square"; 4 | } else if (s instanceof Circle) { 5 | return "Circle"; 6 | } else { 7 | return "Other"; 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /code/objects/immutable.topscript: -------------------------------------------------------------------------------- 1 | 1;; 2 | #part 1 3 | let imm_stack init = object 4 | val v = init 5 | 6 | method pop = 7 | match v with 8 | | hd :: tl -> Some (hd, {< v = tl >}) 9 | | [] -> None 10 | 11 | method push hd = 12 | {< v = hd :: v >} 13 | end ;; 14 | 15 | #part 2 16 | let s = imm_stack [3; 2; 1] ;; 17 | let t = s#push 4 ;; 18 | s#pop ;; 19 | t#pop ;; 20 | -------------------------------------------------------------------------------- /code/objects/is_barbell.ml: -------------------------------------------------------------------------------- 1 | let is_barbell = function 2 | | [Circle r1; Line _; Circle r2] when r1 = r2 -> true 3 | | _ -> false 4 | -------------------------------------------------------------------------------- /code/objects/narrowing.ml: -------------------------------------------------------------------------------- 1 | (* part 1 *) 2 | type shape = < variant : repr; area : float> 3 | and circle = < variant : repr; area : float; radius : int > 4 | and line = < variant : repr; area : float; length : int > 5 | and repr = 6 | | Circle of circle 7 | | Line of line;; 8 | 9 | let is_barbell = function 10 | | [s1; s2; s3] -> 11 | (match s1#variant, s2#variant, s3#variant with 12 | | Circle c1, Line _, Circle c2 when c1#radius = c2#radius -> true 13 | | _ -> false) 14 | | _ -> false;; 15 | -------------------------------------------------------------------------------- /code/objects/polymorphism.topscript: -------------------------------------------------------------------------------- 1 | 1;; 2 | #part 1 3 | let area sq = sq#width * sq#width ;; 4 | let minimize sq : unit = sq#resize 1 ;; 5 | let limit sq = 6 | if (area sq) > 100 then minimize sq ;; 7 | 8 | #part 2 9 | let toggle sq b : unit = 10 | if b then sq#resize `Fullscreen 11 | else minimize sq ;; 12 | 13 | #part 3 14 | let area_closed (sq: < width : int >) = sq#width * sq#width ;; 15 | let sq = object 16 | method width = 30 17 | method name = "sq" 18 | end ;; 19 | area_closed sq ;; 20 | 21 | #part 4 22 | type square = < width : int; ..> ;; 23 | -------------------------------------------------------------------------------- /code/objects/stack.topscript: -------------------------------------------------------------------------------- 1 | 1;; 2 | #part 1 3 | let s = object 4 | val mutable v = [0; 2] 5 | 6 | method pop = 7 | match v with 8 | | hd :: tl -> 9 | v <- tl; 10 | Some hd 11 | | [] -> None 12 | 13 | method push hd = 14 | v <- hd :: v 15 | end ;; 16 | #part 2 17 | s#pop ;; 18 | s#push 4 ;; 19 | s#pop ;; 20 | 21 | #part 3 22 | let stack init = object 23 | val mutable v = init 24 | 25 | method pop = 26 | match v with 27 | | hd :: tl -> 28 | v <- tl; 29 | Some hd 30 | | [] -> None 31 | 32 | method push hd = 33 | v <- hd :: v 34 | end ;; 35 | let s = stack [3; 2; 1] ;; 36 | s#pop ;; 37 | 38 | #part 4 39 | let print_pop st = Option.iter ~f:(printf "Popped: %d\n") st#pop ;; 40 | print_pop (stack [5;4;3;2;1]) ;; 41 | let t = object 42 | method pop = Some (Float.to_int (Time.to_float (Time.now ()))) 43 | end ;; 44 | print_pop t ;; 45 | -------------------------------------------------------------------------------- /code/objects/subtyping.ml: -------------------------------------------------------------------------------- 1 | (* part 1 *) 2 | type shape = < area : float > 3 | 4 | type square = < area : float; width : int > 5 | 6 | let square w = object 7 | method area = Float.of_int (w * w) 8 | method width = w 9 | end 10 | 11 | type circle = < area : float; radius : int > 12 | 13 | let circle r = object 14 | method area = 3.14 *. (Float.of_int r) ** 2.0 15 | method radius = r 16 | end 17 | 18 | (* part 2 *) 19 | type 'a stack = < pop: 'a option; push: 'a -> unit > 20 | 21 | let square_stack: square stack = stack [square 30; square 10] 22 | 23 | let circle_stack: circle stack = stack [circle 20; circle 40] 24 | -------------------------------------------------------------------------------- /code/ocp-index/index_ncurses.sh: -------------------------------------------------------------------------------- 1 | corebuild -pkg ctypes.foreign -tag bin_annot ncurses.cmi 2 | ocp-index complete -I . Ncur 3 | ocp-index complete -I . Ncurses.a 4 | ocp-index complete -I . Ncurses. 5 | -------------------------------------------------------------------------------- /code/ocp-index/ncurses.ml: -------------------------------------------------------------------------------- 1 | ../ffi/ncurses.ml -------------------------------------------------------------------------------- /code/ocp-index/ncurses.mli: -------------------------------------------------------------------------------- 1 | ../ffi/ncurses.mli -------------------------------------------------------------------------------- /code/packing/A.ml: -------------------------------------------------------------------------------- 1 | let v = "hello" 2 | -------------------------------------------------------------------------------- /code/packing/B.ml: -------------------------------------------------------------------------------- 1 | let w = 42 2 | -------------------------------------------------------------------------------- /code/packing/X.mlpack: -------------------------------------------------------------------------------- 1 | A 2 | B 3 | -------------------------------------------------------------------------------- /code/packing/_tags: -------------------------------------------------------------------------------- 1 | <*.cmx> and not "X.cmx": for-pack(X) 2 | -------------------------------------------------------------------------------- /code/packing/build_test.sh: -------------------------------------------------------------------------------- 1 | corebuild test.inferred.mli test.cmi 2 | cat _build/test.inferred.mli 3 | ocamlobjinfo _build/test.cmi 4 | -------------------------------------------------------------------------------- /code/packing/show_files.sh: -------------------------------------------------------------------------------- 1 | cat A.ml 2 | cat B.ml 3 | cat _tags 4 | cat X.mlpack 5 | -------------------------------------------------------------------------------- /code/packing/test.ml: -------------------------------------------------------------------------------- 1 | let v = X.A.v 2 | let w = X.B.w 3 | -------------------------------------------------------------------------------- /code/parsing-test/build_json_parser.sh: -------------------------------------------------------------------------------- 1 | corebuild -use-menhir parser.mli 2 | -------------------------------------------------------------------------------- /code/parsing-test/build_test.sh: -------------------------------------------------------------------------------- 1 | ocamlbuild -use-menhir -tag thread -use-ocamlfind -quiet -pkg core test.native 2 | ./test.native test1.json 3 | -------------------------------------------------------------------------------- /code/parsing-test/json.ml: -------------------------------------------------------------------------------- 1 | ../parsing/json.ml -------------------------------------------------------------------------------- /code/parsing-test/lexer.mll: -------------------------------------------------------------------------------- 1 | ../parsing/lexer.mll -------------------------------------------------------------------------------- /code/parsing-test/parser.mly: -------------------------------------------------------------------------------- 1 | ../parsing/short_parser.mly -------------------------------------------------------------------------------- /code/parsing-test/run_broken_test.errsh: -------------------------------------------------------------------------------- 1 | cat test2.json 2 | ./test.native test2.json 3 | -------------------------------------------------------------------------------- /code/parsing-test/short_parser.mly: -------------------------------------------------------------------------------- 1 | ../parsing/short_parser.mly -------------------------------------------------------------------------------- /code/parsing-test/test1.json: -------------------------------------------------------------------------------- 1 | true 2 | false 3 | null 4 | [1, 2, 3., 4.0, .5, 5.5e5, 6.3] 5 | "Hello World" 6 | { "field1": "Hello", 7 | "field2": 17e13, 8 | "field3": [1, 2, 3], 9 | "field4": { "fieldA": 1, "fieldB": "Hello" } 10 | } 11 | -------------------------------------------------------------------------------- /code/parsing-test/test2.json: -------------------------------------------------------------------------------- 1 | { "name": "Chicago", 2 | "zips": [12345, 3 | } 4 | { "name": "New York", 5 | "zips": [10004] 6 | } 7 | -------------------------------------------------------------------------------- /code/parsing/basic_parser.mly: -------------------------------------------------------------------------------- 1 | %token INT 2 | %token FLOAT 3 | %token ID 4 | %token STRING 5 | %token TRUE 6 | %token FALSE 7 | %token NULL 8 | %token LEFT_BRACE 9 | %token RIGHT_BRACE 10 | %token LEFT_BRACK 11 | %token RIGHT_BRACK 12 | %token COLON 13 | %token COMMA 14 | %token EOF 15 | 16 | %start exp 17 | 18 | %% 19 | 20 | exp: { () } 21 | -------------------------------------------------------------------------------- /code/parsing/build_short_parser.sh: -------------------------------------------------------------------------------- 1 | corebuild -use-menhir short_parser.mli 2 | -------------------------------------------------------------------------------- /code/parsing/example.json: -------------------------------------------------------------------------------- 1 | { 2 | "title": "Cities", 3 | "cities": [ 4 | { "name": "Chicago", "zips": [60601] }, 5 | { "name": "New York", "zips": [10004] } 6 | ] 7 | } 8 | -------------------------------------------------------------------------------- /code/parsing/lex.syntax: -------------------------------------------------------------------------------- 1 | { OCaml code } 2 | let definitions... 3 | rules... 4 | { OCaml code } 5 | -------------------------------------------------------------------------------- /code/parsing/lexer_int_fragment.mll: -------------------------------------------------------------------------------- 1 | | int { INT (int_of_string (Lexing.lexeme lexbuf)) } 2 | -------------------------------------------------------------------------------- /code/parsing/manual_token_type.ml: -------------------------------------------------------------------------------- 1 | type token = 2 | | NULL 3 | | TRUE 4 | | FALSE 5 | | STRING of string 6 | | INT of int 7 | | FLOAT of float 8 | | ID of string 9 | | LEFT_BRACK 10 | | RIGHT_BRACK 11 | | LEFT_BRACE 12 | | RIGHT_BRACE 13 | | COMMA 14 | | COLON 15 | | EOF 16 | -------------------------------------------------------------------------------- /code/parsing/parsed_example.ml: -------------------------------------------------------------------------------- 1 | `Assoc 2 | ["title", `String "Cities"; 3 | "cities", `List 4 | [`Assoc ["name", `String "Chicago"; "zips", `List [`Int 60601]]; 5 | `Assoc ["name", `String "New York"; "zips", `List [`Int 10004]]]] 6 | -------------------------------------------------------------------------------- /code/parsing/production.syntax: -------------------------------------------------------------------------------- 1 | symbol: [ id1 = ] symbol1; [ id2 = ] symbol2; ...; [ idN = ] symbolN 2 | { OCaml code } 3 | -------------------------------------------------------------------------------- /code/parsing/prog.mli: -------------------------------------------------------------------------------- 1 | val prog:(Lexing.lexbuf -> token) -> Lexing.lexbuf -> Json.value option 2 | -------------------------------------------------------------------------------- /code/parsing/tokenized_example.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/realworldocaml/examples/32ea926861a0b728813a29b0e4cf20dd15eb486e/code/parsing/tokenized_example.ml -------------------------------------------------------------------------------- /code/parsing/tokens.ml: -------------------------------------------------------------------------------- 1 | [ LEFT_BRACE; ID("title"); COLON; STRING("Cities"); COMMA; ID("cities"); ... 2 | -------------------------------------------------------------------------------- /code/parsing/yacc.syntax: -------------------------------------------------------------------------------- 1 | 2 | %% 3 | 4 | %% 5 | 6 | -------------------------------------------------------------------------------- /code/principal/build_principal.sh: -------------------------------------------------------------------------------- 1 | corebuild -tag principal principal.cmi non_principal.cmi 2 | -------------------------------------------------------------------------------- /code/principal/non_principal.ml: -------------------------------------------------------------------------------- 1 | ../front-end/non_principal.ml -------------------------------------------------------------------------------- /code/principal/principal.ml: -------------------------------------------------------------------------------- 1 | ../front-end/principal.ml -------------------------------------------------------------------------------- /code/records/functional_update.syntax: -------------------------------------------------------------------------------- 1 | { with = ; 2 | = ; 3 | ... 4 | } 5 | -------------------------------------------------------------------------------- /code/records/record.syntax: -------------------------------------------------------------------------------- 1 | type = 2 | { : ; 3 | : ; 4 | ... 5 | } 6 | -------------------------------------------------------------------------------- /code/records/warn_help.sh: -------------------------------------------------------------------------------- 1 | ocaml -warn-help | egrep '\b9\b' 2 | -------------------------------------------------------------------------------- /code/sexpr/auto_making_sexp.topscript: -------------------------------------------------------------------------------- 1 | type t = { foo: int; bar: float } with sexp ;; 2 | t_of_sexp (Sexp.of_string "((bar 35) (foo 3))") ;; 3 | #part 1 4 | exception Bad_message of string list ;; 5 | Exn.to_string (Bad_message ["1";"2";"3"]) ;; 6 | exception Good_message of string list with sexp;; 7 | Exn.to_string (Good_message ["1";"2";"3"]) ;; 8 | -------------------------------------------------------------------------------- /code/sexpr/basic.scm: -------------------------------------------------------------------------------- 1 | (this (is an) (s expression)) 2 | -------------------------------------------------------------------------------- /code/sexpr/build_read_foo.errsh: -------------------------------------------------------------------------------- 1 | corebuild read_foo.native 2 | ./read_foo.native foo_example_broken.scm 3 | -------------------------------------------------------------------------------- /code/sexpr/build_read_foo_better_errors.errsh: -------------------------------------------------------------------------------- 1 | corebuild read_foo_better_errors.native 2 | ./read_foo_better_errors.native foo_example_broken.scm 3 | -------------------------------------------------------------------------------- /code/sexpr/build_test_interval.sh: -------------------------------------------------------------------------------- 1 | corebuild test_interval.native 2 | ./test_interval.native 3 | -------------------------------------------------------------------------------- /code/sexpr/build_test_interval_manual_sexp.sh: -------------------------------------------------------------------------------- 1 | corebuild test_interval_manual_sexp.native 2 | -------------------------------------------------------------------------------- /code/sexpr/build_test_interval_nosexp.errsh: -------------------------------------------------------------------------------- 1 | corebuild test_interval_nosexp.native 2 | -------------------------------------------------------------------------------- /code/sexpr/comment_heavy.scm: -------------------------------------------------------------------------------- 1 | ;; comment_heavy_example.scm 2 | ((this is included) 3 | ; (this is commented out 4 | (this stays) 5 | #; (all of this is commented 6 | out (even though it crosses lines.)) 7 | (and #| block delimiters #| which can be nested |# 8 | will comment out 9 | an arbitrary multi-line block))) |# 10 | now we're done 11 | )) 12 | -------------------------------------------------------------------------------- /code/sexpr/example.scm: -------------------------------------------------------------------------------- 1 | ;; example.scm 2 | 3 | ((foo 3.3) ;; This is a comment 4 | (bar "this is () an \" atom")) 5 | -------------------------------------------------------------------------------- /code/sexpr/example_broken.scm: -------------------------------------------------------------------------------- 1 | ;; example.scm 2 | 3 | ((foo 3.3) ;; This is a comment 4 | bar "this is () an \" atom")) 5 | -------------------------------------------------------------------------------- /code/sexpr/example_load.topscript: -------------------------------------------------------------------------------- 1 | Sexp.load_sexp "example.scm" ;; 2 | #part 1 3 | Sexp.load_sexp "comment_heavy.scm" ;; 4 | #part 2 5 | Exn.handle_uncaught ~exit:false (fun () -> 6 | ignore (Sexp.load_sexp "example_broken.scm")) ;; 7 | -------------------------------------------------------------------------------- /code/sexpr/foo_broken_example.scm: -------------------------------------------------------------------------------- 1 | ((a "not-an-integer") 2 | (b "not-an-integer") 3 | (c 1.0)) 4 | -------------------------------------------------------------------------------- /code/sexpr/inline_sexp.topscript: -------------------------------------------------------------------------------- 1 | let l = [(1,"one"); (2,"two")] ;; 2 | List.iter l ~f:(fun x -> 3 | <:sexp_of> x 4 | |> Sexp.to_string 5 | |> print_endline) ;; 6 | -------------------------------------------------------------------------------- /code/sexpr/int_interval.ml: -------------------------------------------------------------------------------- 1 | (* Module for representing closed integer intervals *) 2 | open Core.Std 3 | 4 | (* Invariant: For any Range (x,y), y >= x *) 5 | type t = 6 | | Range of int * int 7 | | Empty 8 | with sexp 9 | 10 | let is_empty = 11 | function 12 | | Empty -> true 13 | | Range _ -> false 14 | 15 | let create x y = 16 | if x > y then 17 | Empty 18 | else 19 | Range (x,y) 20 | 21 | let contains i x = 22 | match i with 23 | | Empty -> false 24 | | Range (low,high) -> x >= low && x <= high 25 | -------------------------------------------------------------------------------- /code/sexpr/int_interval.mli: -------------------------------------------------------------------------------- 1 | type t with sexp 2 | 3 | val is_empty : t -> bool 4 | val create : int -> int -> t 5 | val contains : t -> int -> bool 6 | 7 | -------------------------------------------------------------------------------- /code/sexpr/int_interval_manual_sexp.ml: -------------------------------------------------------------------------------- 1 | (* Module for representing closed integer intervals *) 2 | open Core.Std 3 | 4 | (* Invariant: For any Range (x,y), y >= x *) 5 | type t = 6 | | Range of int * int 7 | | Empty 8 | with sexp 9 | 10 | let is_empty = 11 | function 12 | | Empty -> true 13 | | Range _ -> false 14 | 15 | let create x y = 16 | if x > y then 17 | Empty 18 | else 19 | Range (x,y) 20 | 21 | let contains i x = 22 | match i with 23 | | Empty -> false 24 | | Range (low,high) -> x >= low && x <= high 25 | -------------------------------------------------------------------------------- /code/sexpr/int_interval_manual_sexp.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t 4 | val t_of_sexp : Sexp.t -> t 5 | val sexp_of_t : t -> Sexp.t 6 | 7 | val is_empty : t -> bool 8 | val create : int -> int -> t 9 | val contains : t -> int -> bool 10 | -------------------------------------------------------------------------------- /code/sexpr/int_interval_nosexp.ml: -------------------------------------------------------------------------------- 1 | (* Module for representing closed integer intervals *) 2 | open Core.Std 3 | 4 | (* Invariant: For any Range (x,y), y >= x *) 5 | type t = 6 | | Range of int * int 7 | | Empty 8 | with sexp 9 | 10 | let is_empty = 11 | function 12 | | Empty -> true 13 | | Range _ -> false 14 | 15 | let create x y = 16 | if x > y then 17 | Empty 18 | else 19 | Range (x,y) 20 | 21 | let contains i x = 22 | match i with 23 | | Empty -> false 24 | | Range (low,high) -> x >= low && x <= high 25 | -------------------------------------------------------------------------------- /code/sexpr/int_interval_nosexp.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val is_empty : t -> bool 4 | val create : int -> int -> t 5 | val contains : t -> int -> bool 6 | -------------------------------------------------------------------------------- /code/sexpr/list_top_packages.sh: -------------------------------------------------------------------------------- 1 | ocamlfind list | grep top 2 | -------------------------------------------------------------------------------- /code/sexpr/manually_making_sexp.topscript: -------------------------------------------------------------------------------- 1 | type t = { foo: int; bar: float } ;; 2 | let sexp_of_t t = 3 | let a x = Sexp.Atom x and l x = Sexp.List x in 4 | l [ l [a "foo"; Int.sexp_of_t t.foo ]; 5 | l [a "bar"; Float.sexp_of_t t.bar]; ] ;; 6 | sexp_of_t { foo = 3; bar = -5.5 } ;; 7 | -------------------------------------------------------------------------------- /code/sexpr/print_sexp.topscript: -------------------------------------------------------------------------------- 1 | Sexp.List [ 2 | Sexp.Atom "this"; 3 | Sexp.List [ Sexp.Atom "is"; Sexp.Atom "an"]; 4 | Sexp.List [ Sexp.Atom "s"; Sexp.Atom "expression" ]; 5 | ];; 6 | -------------------------------------------------------------------------------- /code/sexpr/read_foo.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t = { 4 | a: string; 5 | b: int; 6 | c: float option 7 | } with sexp 8 | 9 | let run () = 10 | let t = 11 | Sexp.load_sexp "foo_broken_example.scm" 12 | |> t_of_sexp 13 | in 14 | printf "b is: %d\n%!" t.b 15 | 16 | let () = 17 | Exn.handle_uncaught ~exit:true run 18 | -------------------------------------------------------------------------------- /code/sexpr/read_foo_better_errors.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type t = { 4 | a: string; 5 | b: int; 6 | c: float option 7 | } with sexp 8 | 9 | let run () = 10 | let t = Sexp.load_sexp_conv_exn "foo_broken_example.scm" t_of_sexp in 11 | printf "b is: %d\n%!" t.b 12 | 13 | let () = 14 | Exn.handle_uncaught ~exit:true run 15 | -------------------------------------------------------------------------------- /code/sexpr/sexp.mli: -------------------------------------------------------------------------------- 1 | module Sexp : sig 2 | type t = 3 | | Atom of string 4 | | List of t list 5 | end 6 | -------------------------------------------------------------------------------- /code/sexpr/sexp_default.topscript: -------------------------------------------------------------------------------- 1 | type http_server_config = { 2 | web_root: string; 3 | port: int; 4 | addr: string; 5 | } with sexp ;; 6 | #part 1 7 | type http_server_config = { 8 | web_root: string; 9 | port: int with default(80); 10 | addr: string with default("localhost"); 11 | } with sexp ;; 12 | #part 2 13 | let cfg = http_server_config_of_sexp 14 | (Sexp.of_string "((web_root /var/www/html))") ;; 15 | #part 3 16 | sexp_of_http_server_config cfg ;; 17 | #part 4 18 | type http_server_config = { 19 | web_root: string; 20 | port: int with default(80), sexp_drop_default; 21 | addr: string with default("localhost"), sexp_drop_default; 22 | } with sexp ;; 23 | let cfg = http_server_config_of_sexp 24 | (Sexp.of_string "((web_root /var/www/html))") ;; 25 | sexp_of_http_server_config cfg ;; 26 | #part 5 27 | sexp_of_http_server_config { cfg with port = 8080 } ;; 28 | sexp_of_http_server_config 29 | { cfg with port = 8080; addr = "192.168.0.1" } ;; 30 | -------------------------------------------------------------------------------- /code/sexpr/sexp_list.topscript: -------------------------------------------------------------------------------- 1 | type compatible_versions = 2 | | Specific of string list 3 | | All with sexp ;; 4 | sexp_of_compatible_versions 5 | (Specific ["3.12.0"; "3.12.1"; "3.13.0"]) ;; 6 | #part 1 7 | type compatible_versions = 8 | | Specific of string sexp_list 9 | | All with sexp ;; 10 | sexp_of_compatible_versions 11 | (Specific ["3.12.0"; "3.12.1"; "3.13.0"]) ;; 12 | -------------------------------------------------------------------------------- /code/sexpr/sexp_opaque.topscript: -------------------------------------------------------------------------------- 1 | type no_converter = int * int ;; 2 | type t = { a: no_converter; b: string } with sexp ;; 3 | #part 1 4 | type t = { a: no_converter sexp_opaque; b: string } with sexp ;; 5 | #part 2 6 | sexp_of_t { a = (3,4); b = "foo" } ;; 7 | #part 3 8 | t_of_sexp (Sexp.of_string "((a whatever) (b foo))") ;; 9 | #part 4 10 | type t = { a: no_converter sexp_opaque list; b: string } with sexp ;; 11 | t_of_sexp (Sexp.of_string "((a ()) (b foo))") ;; 12 | #part 5 13 | type t = { a: no_converter sexp_opaque; b: string } with sexp_of ;; 14 | type t = { a: no_converter sexp_opaque; b: string } with of_sexp ;; 15 | -------------------------------------------------------------------------------- /code/sexpr/sexp_option.topscript: -------------------------------------------------------------------------------- 1 | type t = { a: int option; b: string } with sexp ;; 2 | sexp_of_t { a = None; b = "hello" } ;; 3 | sexp_of_t { a = Some 3; b = "hello" } ;; 4 | #part 1 5 | type t = { a: int sexp_option; b: string } with sexp ;; 6 | sexp_of_t { a = Some 3; b = "hello" } ;; 7 | sexp_of_t { a = None; b = "hello" } ;; 8 | -------------------------------------------------------------------------------- /code/sexpr/sexp_override.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Range of int * int 3 | | Empty 4 | with sexp 5 | 6 | let create x y = 7 | if x > y then Empty else Range (x,y) 8 | 9 | let t_of_sexp sexp = 10 | let t = t_of_sexp sexp in 11 | begin match t with 12 | | Empty -> () 13 | | Range (x,y) -> 14 | if y < x then of_sexp_error "Upper and lower bound of Range swapped" sexp 15 | end; 16 | t 17 | -------------------------------------------------------------------------------- /code/sexpr/sexp_printer.topscript: -------------------------------------------------------------------------------- 1 | Sexp.to_string (Sexp.List [Sexp.Atom "1"; Sexp.Atom "2"]) ;; 2 | Sexp.of_string ("(1 2 (3 4))") ;; 3 | -------------------------------------------------------------------------------- /code/sexpr/test_interval.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | let intervals = 4 | let module I = Int_interval in 5 | [ I.create 3 4; 6 | I.create 5 4; (* should be empty *) 7 | I.create 2 3; 8 | I.create 1 6; 9 | ] 10 | 11 | let () = 12 | intervals 13 | |> List.sexp_of_t Int_interval.sexp_of_t 14 | |> Sexp.to_string_hum 15 | |> print_endline 16 | -------------------------------------------------------------------------------- /code/sexpr/test_interval_manual_sexp.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | module Int_interval = Int_interval_manual_sexp 3 | 4 | let intervals = 5 | let module I = Int_interval in 6 | [ I.create 3 4; 7 | I.create 5 4; (* should be empty *) 8 | I.create 2 3; 9 | I.create 1 6; 10 | ] 11 | 12 | let () = 13 | intervals 14 | |> List.sexp_of_t Int_interval.sexp_of_t 15 | |> Sexp.to_string_hum 16 | |> print_endline 17 | -------------------------------------------------------------------------------- /code/sexpr/test_interval_nosexp.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | module Int_interval = Int_interval_nosexp 3 | 4 | let intervals = 5 | let module I = Int_interval in 6 | [ I.create 3 4; 7 | I.create 5 4; (* should be empty *) 8 | I.create 2 3; 9 | I.create 1 6; 10 | ] 11 | 12 | let () = 13 | intervals 14 | |> List.sexp_of_t Int_interval.sexp_of_t 15 | |> Sexp.to_string_hum 16 | |> print_endline 17 | -------------------------------------------------------------------------------- /code/sexpr/to_from_sexp.topscript: -------------------------------------------------------------------------------- 1 | Int.sexp_of_t 3;; 2 | String.sexp_of_t "hello";; 3 | Exn.sexp_of_t (Invalid_argument "foo");; 4 | #part 1 5 | List.sexp_of_t;; 6 | List.sexp_of_t Int.sexp_of_t [1; 2; 3];; 7 | #part 2 8 | List.t_of_sexp;; 9 | List.t_of_sexp Int.t_of_sexp (Sexp.of_string "(1 2 3)");; 10 | List.t_of_sexp Int.t_of_sexp (Sexp.of_string "(1 2 three)");; 11 | -------------------------------------------------------------------------------- /code/variables-and-functions/abs_diff.mli: -------------------------------------------------------------------------------- 1 | val abs_diff : int -> (int -> int) 2 | -------------------------------------------------------------------------------- /code/variables-and-functions/htable_sig1.ml: -------------------------------------------------------------------------------- 1 | val create_hashtable : int -> bool -> ('a,'b) Hashtable.t 2 | -------------------------------------------------------------------------------- /code/variables-and-functions/htable_sig2.ml: -------------------------------------------------------------------------------- 1 | val create_hashtable : 2 | init_size:int -> allow_shrinking:bool -> ('a,'b) Hashtable.t 3 | -------------------------------------------------------------------------------- /code/variables-and-functions/let.syntax: -------------------------------------------------------------------------------- 1 | let = 2 | -------------------------------------------------------------------------------- /code/variables-and-functions/let_in.syntax: -------------------------------------------------------------------------------- 1 | let = in 2 | -------------------------------------------------------------------------------- /code/variables-and-functions/numerical_deriv_alt_sig.mli: -------------------------------------------------------------------------------- 1 | val numeric_deriv : 2 | delta:float -> 3 | x:float -> y:float -> f:(?x:float -> y:float -> float) -> float * float 4 | 5 | -------------------------------------------------------------------------------- /code/variables-and-functions/operators.syntax: -------------------------------------------------------------------------------- 1 | ! $ % & * + - . / : < = > ? @ ^ | ~ 2 | -------------------------------------------------------------------------------- /code/variables-and-functions/substring_sig1.ml: -------------------------------------------------------------------------------- 1 | val substring: string -> int -> int -> string 2 | -------------------------------------------------------------------------------- /code/variables-and-functions/substring_sig2.ml: -------------------------------------------------------------------------------- 1 | val substring: string -> pos:int -> len:int -> string 2 | -------------------------------------------------------------------------------- /code/variants-termcol-annotated/build.errsh: -------------------------------------------------------------------------------- 1 | corebuild terminal_color.native 2 | -------------------------------------------------------------------------------- /code/variants-termcol-annotated/terminal_color.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type basic_color = 4 | [ `Black | `Blue | `Cyan | `Green 5 | | `Magenta | `Red | `White | `Yellow ] 6 | 7 | type color = 8 | [ `Basic of basic_color * [ `Bold | `Regular ] 9 | | `Gray of int 10 | | `RGB of int * int * int ] 11 | 12 | type extended_color = 13 | [ color 14 | | `RGBA of int * int * int * int ] 15 | 16 | val color_to_int : color -> int 17 | val extended_color_to_int : extended_color -> int 18 | -------------------------------------------------------------------------------- /code/variants-termcol-fixed/build.sh: -------------------------------------------------------------------------------- 1 | corebuild terminal_color.native 2 | -------------------------------------------------------------------------------- /code/variants-termcol-fixed/terminal_color.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type basic_color = 4 | [ `Black | `Blue | `Cyan | `Green 5 | | `Magenta | `Red | `White | `Yellow ] 6 | 7 | type color = 8 | [ `Basic of basic_color * [ `Bold | `Regular ] 9 | | `Gray of int 10 | | `RGB of int * int * int ] 11 | 12 | type extended_color = 13 | [ color 14 | | `RGBA of int * int * int * int ] 15 | 16 | let basic_color_to_int = function 17 | | `Black -> 0 | `Red -> 1 | `Green -> 2 | `Yellow -> 3 18 | | `Blue -> 4 | `Magenta -> 5 | `Cyan -> 6 | `White -> 7 19 | 20 | let color_to_int = function 21 | | `Basic (basic_color,weight) -> 22 | let base = match weight with `Bold -> 8 | `Regular -> 0 in 23 | base + basic_color_to_int basic_color 24 | | `RGB (r,g,b) -> 16 + b + g * 6 + r * 36 25 | | `Gray i -> 232 + i 26 | 27 | (* part 1 *) 28 | let extended_color_to_int : extended_color -> int = function 29 | | `RGBA (r,g,b,a) -> 256 + a + b * 6 + g * 36 + r * 216 30 | | #color as color -> color_to_int color 31 | -------------------------------------------------------------------------------- /code/variants-termcol-fixed/terminal_color.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type basic_color = 4 | [ `Black | `Blue | `Cyan | `Green 5 | | `Magenta | `Red | `White | `Yellow ] 6 | 7 | type color = 8 | [ `Basic of basic_color * [ `Bold | `Regular ] 9 | | `Gray of int 10 | | `RGB of int * int * int ] 11 | 12 | type extended_color = 13 | [ color 14 | | `RGBA of int * int * int * int ] 15 | 16 | val color_to_int : color -> int 17 | val extended_color_to_int : extended_color -> int 18 | -------------------------------------------------------------------------------- /code/variants-termcol/build.sh: -------------------------------------------------------------------------------- 1 | corebuild terminal_color.native 2 | -------------------------------------------------------------------------------- /code/variants-termcol/terminal_color.ml: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type basic_color = 4 | [ `Black | `Blue | `Cyan | `Green 5 | | `Magenta | `Red | `White | `Yellow ] 6 | 7 | type color = 8 | [ `Basic of basic_color * [ `Bold | `Regular ] 9 | | `Gray of int 10 | | `RGB of int * int * int ] 11 | 12 | type extended_color = 13 | [ color 14 | | `RGBA of int * int * int * int ] 15 | 16 | let basic_color_to_int = function 17 | | `Black -> 0 | `Red -> 1 | `Green -> 2 | `Yellow -> 3 18 | | `Blue -> 4 | `Magenta -> 5 | `Cyan -> 6 | `White -> 7 19 | 20 | let color_to_int = function 21 | | `Basic (basic_color,weight) -> 22 | let base = match weight with `Bold -> 8 | `Regular -> 0 in 23 | base + basic_color_to_int basic_color 24 | | `RGB (r,g,b) -> 16 + b + g * 6 + r * 36 25 | | `Gray i -> 232 + i 26 | 27 | let extended_color_to_int = function 28 | | `RGBA (r,g,b,a) -> 256 + a + b * 6 + g * 36 + r * 216 29 | | `Grey x -> 2000 + x 30 | | (`Basic _ | `RGB _ | `Gray _) as color -> color_to_int color 31 | -------------------------------------------------------------------------------- /code/variants-termcol/terminal_color.mli: -------------------------------------------------------------------------------- 1 | open Core.Std 2 | 3 | type basic_color = 4 | [ `Black | `Blue | `Cyan | `Green 5 | | `Magenta | `Red | `White | `Yellow ] 6 | 7 | type color = 8 | [ `Basic of basic_color * [ `Bold | `Regular ] 9 | | `Gray of int 10 | | `RGB of int * int * int ] 11 | 12 | type extended_color = 13 | [ color 14 | | `RGBA of int * int * int * int ] 15 | 16 | val color_to_int : color -> int 17 | val extended_color_to_int : extended_color -> int 18 | -------------------------------------------------------------------------------- /code/variants/main-2.rawscript: -------------------------------------------------------------------------------- 1 | # let color_by_number number text = 2 | sprintf "\027[38;5;%dm%s\027[0m" number text;; 3 | val color_by_number : int -> string -> string = 4 | # let blue = color_by_number (basic_color_to_int Blue) "Blue";; 5 | val blue : string = "\027[38;5;4mBlue\027[0m" 6 | # printf "Hello %s World!\n" blue;; 7 | Hello Blue World! 8 | -------------------------------------------------------------------------------- /code/variants/main-5.rawscript: -------------------------------------------------------------------------------- 1 | # let color_print color s = 2 | printf "%s\n" (color_by_number (color_to_int color) s);; 3 | val color_print : color -> string -> unit = 4 | # color_print (Basic (Red,Bold)) "A bold red!";; 5 | A bold red! 6 | # color_print (Gray 4) "A muted gray...";; 7 | A muted gray... 8 | -------------------------------------------------------------------------------- /code/variants/variant.syntax: -------------------------------------------------------------------------------- 1 | type = 2 | | [ of [* ]... ] 3 | | [ of [* ]... ] 4 | | ... 5 | --------------------------------------------------------------------------------