example.ml: The first special comment of the file is the comment
associated with the whole module.
================================================
FILE: code/front-end/html/index_attributes.html
================================================
Index of class attributes
================================================
FILE: code/front-end/html/index_class_types.html
================================================
Index of class types
================================================
FILE: code/front-end/html/index_classes.html
================================================
Index of classes
================================================
FILE: code/front-end/html/index_exceptions.html
================================================
Index of exceptions
================================================
FILE: code/front-end/html/index_methods.html
================================================
Index of class methods
================================================
FILE: code/front-end/html/index_module_types.html
================================================
Index of module types
================================================
FILE: code/front-end/html/index_modules.html
================================================
Index of modules
example.ml: The first special comment of the file is the comment
associated with the whole module.
================================================
FILE: code/front-end/html/index_types.html
================================================
Index of types
================================================
FILE: code/front-end/html/index_values.html
================================================
Index of values
================================================
FILE: code/front-end/html/style.css
================================================
.keyword { font-weight : bold ; color : Red }
.keywordsign { color : #C04600 }
.superscript { font-size : 4 }
.subscript { font-size : 4 }
.comment { color : Green }
.constructor { color : Blue }
.type { color : #5C6585 }
.string { color : Maroon }
.warning { color : Red ; font-weight : bold }
.info { margin-left : 3em; margin-right: 3em }
.param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em }
.code { color : #465F91 ; }
.typetable { border-style : hidden }
.paramstable { border-style : hidden ; padding: 5pt 5pt}
tr { background-color : White }
td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;}
div.sig_block {margin-left: 2em}
*:target { background: yellow; }
body {font: 13px sans-serif; color: black; text-align: left; padding: 5px; margin: 0}
h1 { font-size : 20pt ; text-align: center; }
h2 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90BDFF ;padding: 2px; }
h3 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90DDFF ;padding: 2px; }
h4 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90EDFF ;padding: 2px; }
h5 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90FDFF ;padding: 2px; }
h6 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90BDFF ; padding: 2px; }
div.h7 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #E0FFFF ; padding: 2px; }
div.h8 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #F0FFFF ; padding: 2px; }
div.h9 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #FFFFFF ; padding: 2px; }
a {color: #416DFF; text-decoration: none}
a:hover {background-color: #ddd; text-decoration: underline}
pre { margin-bottom: 4px; font-family: monospace; }
pre.verbatim, pre.codepre { }
.indextable {border: 1px #ddd solid; border-collapse: collapse}
.indextable td, .indextable th {border: 1px #ddd solid; min-width: 80px}
.indextable td.module {background-color: #eee ; padding-left: 2px; padding-right: 2px}
.indextable td.module a {color: 4E6272; text-decoration: none; display: block; width: 100%}
.indextable td.module a:hover {text-decoration: underline; background-color: transparent}
.deprecated {color: #888; font-style: italic}
.indextable tr td div.info { margin-left: 2px; margin-right: 2px }
ul.indexlist { margin-left: 0; padding-left: 0;}
ul.indexlist li { list-style-type: none ; margin-left: 0; padding-left: 0; }
================================================
FILE: code/front-end/html/type_Doc.html
================================================
Docsigend
================================================
FILE: code/front-end/inconsistent_compilation_units.rawsh
================================================
$ ocamlc -c foo.ml
File "foo.ml", line 1, characters 0-1:
Error: The files /home/build/bar.cmi
and /usr/lib/ocaml/map.cmi make inconsistent assumptions
over interface Map
================================================
FILE: code/front-end/indent_follow_on_function.sh
================================================
ocp-indent follow_on_function.ml
================================================
FILE: code/front-end/indent_follow_on_function_fixed.sh
================================================
ocp-indent follow_on_function_fixed.ml
================================================
FILE: code/front-end/infer_typedef.sh
================================================
ocamlc -i typedef.ml
================================================
FILE: code/front-end/install_ocp_index.rawsh
================================================
$ opam install ocp-index
$ ocp-index
================================================
FILE: code/front-end/let_notunit.ml
================================================
let (_:some_type) =
let () = ignore ( : some_type)
)(* if the expression returns a unit Deferred.t *)
let () = don't_wait_for (
================================================
FILE: code/front-end/let_unit.syntax
================================================
let () =
================================================
FILE: code/front-end/man/man3/Doc.3o
================================================
.TH "Doc" 3 2013-07-23 OCamldoc ""
.SH NAME
Doc \- example.ml: The first special comment of the file is the comment associated with the whole module.
.SH Module
Module Doc
.SH Documentation
.sp
Module
.BI "Doc"
:
.B sig end
.sp
example\&.ml: The first special comment of the file is the comment
associated with the whole module\&.
.sp
.sp
.sp
.sp
.I exception My_exception
.B of
.B (int -> int) * int
.sp
Comment for exception My_exception\&.
.sp
.sp
.I type weather
=
| Rain
.B of
.B int
.I " "
(* The comment for construtor Rain *)
| Sun (* The comment for constructor Sun *)
.sp
Comment for type
.B weather
.sp
.sp
.I val what_is_the_weather_in
:
.B [< `California | `Cambridge | `New_york ] -> weather
.sp
Find the current weather for a country
.sp
.B "Author(s)"
:
Anil Madhavapeddy
.sp
.sp
================================================
FILE: code/front-end/man/man3/My_exception.3o
================================================
.TH "My_exception" 3 2013-07-23 OCamldoc ""
.SH NAME
My_exception \- all My_exception elements
.SH Module Doc
.I exception My_exception
.B of
.B (int -> int) * int
.sp
Comment for exception My_exception\&.
.sp
.sp
================================================
FILE: code/front-end/man/man3/Rain.3o
================================================
.TH "Rain" 3 2013-07-23 OCamldoc ""
.SH NAME
Rain \- all Rain elements
================================================
FILE: code/front-end/man/man3/Sun.3o
================================================
.TH "Sun" 3 2013-07-23 OCamldoc ""
.SH NAME
Sun \- all Sun elements
================================================
FILE: code/front-end/man/man3/weather.3o
================================================
.TH "weather" 3 2013-07-23 OCamldoc ""
.SH NAME
weather \- all weather elements
.SH Module Doc
.I type weather
=
| Rain
.B of
.B int
.I " "
(* The comment for construtor Rain *)
| Sun (* The comment for constructor Sun *)
.sp
Comment for type
.B weather
.sp
.sp
================================================
FILE: code/front-end/man/man3/what_is_the_weather_in.3o
================================================
.TH "what_is_the_weather_in" 3 2013-07-23 OCamldoc ""
.SH NAME
what_is_the_weather_in \- all what_is_the_weather_in elements
.SH Module Doc
.I val what_is_the_weather_in
:
.B [< `California | `Cambridge | `New_york ] -> weather
.sp
Find the current weather for a country
.sp
.B "Author(s)"
:
Anil Madhavapeddy
.sp
.sp
================================================
FILE: code/front-end/non_principal.ml
================================================
type s = { foo: int; bar: unit }
type t = { foo: int }
let f x =
x.bar;
x.foo
================================================
FILE: code/front-end/parsetree_typedef.sh
================================================
ocamlc -dparsetree typedef.ml 2>&1
================================================
FILE: code/front-end/pipeline.ascii
================================================
Source code
|
| parsing and preprocessing
|
| camlp4 syntax extensions
|
v
Parsetree (untyped AST)
|
| type inference and checking
v
Typedtree (type-annotated AST)
|
| pattern-matching compilation
| elimination of modules and classes
v
Lambda
/ \
/ \ closure conversion, inlining, uncurrying,
v \ data representation strategy
Bytecode \
| +-----+
| Cmm
|ocamlrun |
| | code generation
| | assembly & linking
v v
Interpreted Compiled
================================================
FILE: code/front-end/principal.ml
================================================
type s = { foo: int; bar: unit }
type t = { foo: int }
let f (x:s) =
x.bar;
x.foo
================================================
FILE: code/front-end/process_comparelib_interface.sh
================================================
sh camlp4_dump.cmd comparelib_test.mli
================================================
FILE: code/front-end/process_comparelib_test.sh
================================================
sh camlp4_dump.cmd comparelib_test.ml
================================================
FILE: code/front-end/short_paths_1.rawsh
================================================
$ ocaml
# List.map print_endline "" ;;
Error: This expression has type string but an expression was expected of type
string list
================================================
FILE: code/front-end/short_paths_2.rawsh
================================================
$ ocaml
# open Core.Std ;;
# List.map ~f:print_endline "" ;;
Error: This expression has type string but an expression was expected of type
'a Core.Std.List.t = 'a list
================================================
FILE: code/front-end/short_paths_3.rawsh
================================================
$ ocaml -short-paths
# open Core.Std;;
# List.map ~f:print_endline "foo";;
Error: This expression has type string but an expression was expected of type
'a list
================================================
FILE: code/front-end/test.ml
================================================
type t = Foo
================================================
FILE: code/front-end/test.mli
================================================
type t = Bar
================================================
FILE: code/front-end/type_conv_example.ml
================================================
open Sexplib.Std
type t = {
foo: int;
bar: string
} with sexp, fields
================================================
FILE: code/front-end/typedef.ml
================================================
type t = Foo | Bar
let v = Foo
================================================
FILE: code/front-end/typedef_objinfo.sh
================================================
ocamlc -c typedef.ml
ocamlobjinfo typedef.cmi
================================================
FILE: code/front-end/typedtree_typedef.sh
================================================
ocamlc -dtypedtree typedef.ml 2>&1
================================================
FILE: code/front-end/unused_var.ml
================================================
let fn x y =
let _z = x + y in
()
================================================
FILE: code/front-end/xbuild_type_conv_with_camlp4.sh
================================================
ocamlfind ocamlc -c -syntax camlp4o -package sexplib.syntax -package fieldslib.syntax type_conv_example.ml
================================================
FILE: code/functors/build_extended_fqueue.sh
================================================
corebuild extended_fqueue.cmo
================================================
FILE: code/functors/build_fqueue.sh
================================================
corebuild fqueue.cmo
================================================
FILE: code/functors/compare_example.ml
================================================
compare x y < 0 (* x < y *)
compare x y = 0 (* x = y *)
compare x y > 0 (* x > y *)
================================================
FILE: code/functors/destructive_sub.syntax
================================================
with type :=
================================================
FILE: code/functors/extended_fqueue.ml
================================================
include Fqueue
include Foldable.Extend(Fqueue)
================================================
FILE: code/functors/extended_fqueue.mli
================================================
type 'a t
include (module type of Fqueue) with type 'a t := 'a t
include Foldable.Extension with type 'a t := 'a t
================================================
FILE: code/functors/foldable.ml
================================================
open Core.Std
module type S = sig
type 'a t
val fold : 'a t -> init:'acc -> f:('acc -> 'a -> 'acc) -> 'acc
end
module type Extension = sig
type 'a t
val iter : 'a t -> f:('a -> unit) -> unit
val length : 'a t -> int
val count : 'a t -> f:('a -> bool) -> int
val for_all : 'a t -> f:('a -> bool) -> bool
val exists : 'a t -> f:('a -> bool) -> bool
end
(* For extending a Foldable module *)
module Extend(Arg : S)
: (Extension with type 'a t := 'a Arg.t) =
struct
open Arg
let iter t ~f =
fold t ~init:() ~f:(fun () a -> f a)
let length t =
fold t ~init:0 ~f:(fun acc _ -> acc + 1)
let count t ~f =
fold t ~init:0 ~f:(fun count x -> count + if f x then 1 else 0)
exception Short_circuit
let for_all c ~f =
try iter c ~f:(fun x -> if not (f x) then raise Short_circuit); true
with Short_circuit -> false
let exists c ~f =
try iter c ~f:(fun x -> if f x then raise Short_circuit); false
with Short_circuit -> true
end
================================================
FILE: code/functors/fqueue.ml
================================================
open Core.Std
type 'a t = 'a list * 'a list
let empty = ([],[])
let enqueue (in_list, out_list) x =
(x :: in_list,out_list)
let dequeue (in_list, out_list) =
match out_list with
| hd :: tl -> Some (hd, (in_list, tl))
| [] ->
match List.rev in_list with
| [] -> None
| hd :: tl -> Some (hd, ([], tl))
let fold (in_list, out_list) ~init ~f =
let after_out = List.fold ~init ~f out_list in
List.fold_right ~init:after_out ~f:(fun x acc -> f acc x) in_list
================================================
FILE: code/functors/fqueue.mli
================================================
type 'a t
val empty : 'a t
(** [enqueue el q] adds [el] to the back of [q] *)
val enqueue : 'a t -> 'a -> 'a t
(** [dequeue q] returns None if the [q] is empty, otherwise returns
the first element of the queue and the remainder of the queue *)
val dequeue : 'a t -> ('a * 'a t) option
(** Folds over the queue, from front to back *)
val fold : 'a t -> init:'acc -> f:('acc -> 'a -> 'acc) -> 'acc
================================================
FILE: code/functors/main-15.rawscript
================================================
# module Make_interval(Endpoint : Comparable) : Interval_intf = struct
type endpoint = Endpoint.t
type t = | Interval of Endpoint.t * Endpoint.t
| Empty
...
end ;;
module Make_interval : functor (Endpoint : Comparable) -> Interval_intf
================================================
FILE: code/functors/main-18.rawscript
================================================
# module Make_interval(Endpoint : Comparable)
: (Interval_intf with type endpoint = Endpoint.t)
= struct
type endpoint = Endpoint.t
type t = | Interval of Endpoint.t * Endpoint.t
| Empty
...
end ;;
module Make_interval :
functor (Endpoint : Comparable) ->
sig
type t
type endpoint = Endpoint.t
val create : endpoint -> endpoint -> t
val is_empty : t -> bool
val contains : t -> endpoint -> bool
val intersect : t -> t -> t
end
================================================
FILE: code/functors/main-21.rawscript
================================================
# module Make_interval(Endpoint : Comparable)
: Interval_intf with type endpoint := Endpoint.t =
struct
type t = | Interval of Endpoint.t * Endpoint.t
| Empty
...
end ;;
module Make_interval :
functor (Endpoint : Comparable) ->
sig
type t
val create : Endpoint.t -> Endpoint.t -> t
val is_empty : t -> bool
val contains : t -> Endpoint.t -> bool
val intersect : t -> t -> t
end
================================================
FILE: code/functors/main-25.rawscript
================================================
# module Make_interval(Endpoint : Comparable)
: (Interval_intf with type endpoint := Endpoint.t) = struct
type t = | Interval of Endpoint.t * Endpoint.t
| Empty
with sexp
...
end ;;
Characters 136-146:
Error: Unbound value Endpoint.t_of_sexp
================================================
FILE: code/functors/main.topscript
================================================
module type X_int = sig val x : int end;;
#part 1
module Increment (M : X_int) : X_int = struct
let x = M.x + 1
end;;
#part 2
module Increment (M : X_int) = struct
let x = M.x + 1
end;;
#part 3
module Three = struct let x = 3 end;;
module Four = Increment(Three);;
Four.x - Three.x;;
#part 4
module Three_and_more = struct
let x = 3
let y = "three"
end;;
module Four = Increment(Three_and_more);;
#part 5
module type Comparable = sig
type t
val compare : t -> t -> int
end ;;
#part 6
module Make_interval(Endpoint : Comparable) = struct
type t = | Interval of Endpoint.t * Endpoint.t
| Empty
(** [create low high] creates a new interval from [low] to
[high]. If [low > high], then the interval is empty *)
let create low high =
if Endpoint.compare low high > 0 then Empty
else Interval (low,high)
(** Returns true iff the interval is empty *)
let is_empty = function
| Empty -> true
| Interval _ -> false
(** [contains t x] returns true iff [x] is contained in the
interval [t] *)
let contains t x =
match t with
| Empty -> false
| Interval (l,h) ->
Endpoint.compare x l >= 0 && Endpoint.compare x h <= 0
(** [intersect t1 t2] returns the intersection of the two input
intervals *)
let intersect t1 t2 =
let min x y = if Endpoint.compare x y <= 0 then x else y in
let max x y = if Endpoint.compare x y >= 0 then x else y in
match t1,t2 with
| Empty, _ | _, Empty -> Empty
| Interval (l1,h1), Interval (l2,h2) ->
create (max l1 l2) (min h1 h2)
end ;;
#part 7
module Int_interval =
Make_interval(struct
type t = int
let compare = Int.compare
end);;
#part 8
module Int_interval = Make_interval(Int) ;;
module String_interval = Make_interval(String) ;;
#part 9
let i1 = Int_interval.create 3 8;;
let i2 = Int_interval.create 4 10;;
Int_interval.intersect i1 i2;;
#part 10
module Rev_int_interval =
Make_interval(struct
type t = int
let compare x y = Int.compare y x
end);;
#part 11
let interval = Int_interval.create 4 3;;
let rev_interval = Rev_int_interval.create 4 3;;
#part 12
Int_interval.contains rev_interval 3;;
#part 13
Int_interval.is_empty (* going through create *)
(Int_interval.create 4 3) ;;
Int_interval.is_empty (* bypassing create *)
(Int_interval.Interval (4,3)) ;;
#part 14
module type Interval_intf = sig
type t
type endpoint
val create : endpoint -> endpoint -> t
val is_empty : t -> bool
val contains : t -> endpoint -> bool
val intersect : t -> t -> t
end;;
#part 15
module Make_interval(Endpoint : Comparable) : Interval_intf = struct
type endpoint = Endpoint.t
type t = | Interval of Endpoint.t * Endpoint.t
| Empty
(** [create low high] creates a new interval from [low] to
[high]. If [low > high], then the interval is empty *)
let create low high =
if Endpoint.compare low high > 0 then Empty
else Interval (low,high)
(** Returns true iff the interval is empty *)
let is_empty = function
| Empty -> true
| Interval _ -> false
(** [contains t x] returns true iff [x] is contained in the
interval [t] *)
let contains t x =
match t with
| Empty -> false
| Interval (l,h) ->
Endpoint.compare x l >= 0 && Endpoint.compare x h <= 0
(** [intersect t1 t2] returns the intersection of the two input
intervals *)
let intersect t1 t2 =
let min x y = if Endpoint.compare x y <= 0 then x else y in
let max x y = if Endpoint.compare x y >= 0 then x else y in
match t1,t2 with
| Empty, _ | _, Empty -> Empty
| Interval (l1,h1), Interval (l2,h2) ->
create (max l1 l2) (min h1 h2)
end ;;
#part 16
module Int_interval = Make_interval(Int);;
Int_interval.create 3 4;;
#part 17
module type Int_interval_intf =
Interval_intf with type endpoint = int;;
#part 18
module Make_interval(Endpoint : Comparable)
: (Interval_intf with type endpoint = Endpoint.t)
= struct
type endpoint = Endpoint.t
type t = | Interval of Endpoint.t * Endpoint.t
| Empty
(** [create low high] creates a new interval from [low] to
[high]. If [low > high], then the interval is empty *)
let create low high =
if Endpoint.compare low high > 0 then Empty
else Interval (low,high)
(** Returns true iff the interval is empty *)
let is_empty = function
| Empty -> true
| Interval _ -> false
(** [contains t x] returns true iff [x] is contained in the
interval [t] *)
let contains t x =
match t with
| Empty -> false
| Interval (l,h) ->
Endpoint.compare x l >= 0 && Endpoint.compare x h <= 0
(** [intersect t1 t2] returns the intersection of the two input
intervals *)
let intersect t1 t2 =
let min x y = if Endpoint.compare x y <= 0 then x else y in
let max x y = if Endpoint.compare x y >= 0 then x else y in
match t1,t2 with
| Empty, _ | _, Empty -> Empty
| Interval (l1,h1), Interval (l2,h2) ->
create (max l1 l2) (min h1 h2)
end ;;
#part 19
module Int_interval = Make_interval(Int);;
let i = Int_interval.create 3 4;;
Int_interval.contains i 5;;
#part 20
module type Int_interval_intf =
Interval_intf with type endpoint := int;;
#part 21
module Make_interval(Endpoint : Comparable)
: Interval_intf with type endpoint := Endpoint.t =
struct
type t = | Interval of Endpoint.t * Endpoint.t
| Empty
(** [create low high] creates a new interval from [low] to
[high]. If [low > high], then the interval is empty *)
let create low high =
if Endpoint.compare low high > 0 then Empty
else Interval (low,high)
(** Returns true iff the interval is empty *)
let is_empty = function
| Empty -> true
| Interval _ -> false
(** [contains t x] returns true iff [x] is contained in the
interval [t] *)
let contains t x =
match t with
| Empty -> false
| Interval (l,h) ->
Endpoint.compare x l >= 0 && Endpoint.compare x h <= 0
(** [intersect t1 t2] returns the intersection of the two input
intervals *)
let intersect t1 t2 =
let min x y = if Endpoint.compare x y <= 0 then x else y in
let max x y = if Endpoint.compare x y >= 0 then x else y in
match t1,t2 with
| Empty, _ | _, Empty -> Empty
| Interval (l1,h1), Interval (l2,h2) ->
create (max l1 l2) (min h1 h2)
end ;;
#part 22
module Int_interval = Make_interval(Int);;
Int_interval.is_empty
(Int_interval.create 3 4);;
Int_interval.is_empty
(Int_interval.Interval (4,3));;
#part 23
Sexp.of_string "(This is (an s-expression))";;
#part 24
type some_type = int * string list with sexp;;
sexp_of_some_type (33, ["one"; "two"]);;
Sexp.of_string "(44 (five six))" |> some_type_of_sexp;;
#part 25
module Make_interval(Endpoint : Comparable)
: (Interval_intf with type endpoint := Endpoint.t) = struct
type t = | Interval of Endpoint.t * Endpoint.t
| Empty
with sexp
(** [create low high] creates a new interval from [low] to
[high]. If [low > high], then the interval is empty *)
let create low high =
if Endpoint.compare low high > 0 then Empty
else Interval (low,high)
(** Returns true iff the interval is empty *)
let is_empty = function
| Empty -> true
| Interval _ -> false
(** [contains t x] returns true iff [x] is contained in the
interval [t] *)
let contains t x =
match t with
| Empty -> false
| Interval (l,h) ->
Endpoint.compare x l >= 0 && Endpoint.compare x h <= 0
(** [intersect t1 t2] returns the intersection of the two input
intervals *)
let intersect t1 t2 =
let min x y = if Endpoint.compare x y <= 0 then x else y in
let max x y = if Endpoint.compare x y >= 0 then x else y in
match t1,t2 with
| Empty, _ | _, Empty -> Empty
| Interval (l1,h1), Interval (l2,h2) ->
create (max l1 l2) (min h1 h2)
end ;;
#part 26
module type Interval_intf_with_sexp = sig
include Interval_intf
include Sexpable with type t := t
end;;
#part 27
module type Interval_intf_with_sexp = sig
type t
include Interval_intf with type t := t
include Sexpable with type t := t
end;;
#part 28
module Make_interval(Endpoint : sig
type t
include Comparable with type t := t
include Sexpable with type t := t
end)
: (Interval_intf_with_sexp with type endpoint := Endpoint.t)
= struct
type t = | Interval of Endpoint.t * Endpoint.t
| Empty
with sexp
(** [create low high] creates a new interval from [low] to
[high]. If [low > high], then the interval is empty *)
let create low high =
if Endpoint.compare low high > 0 then Empty
else Interval (low,high)
(* put a wrapper around the autogenerated [t_of_sexp] to enforce
the invariants of the data structure *)
let t_of_sexp sexp =
match t_of_sexp sexp with
| Empty -> Empty
| Interval (x,y) -> create x y
(** Returns true iff the interval is empty *)
let is_empty = function
| Empty -> true
| Interval _ -> false
(** [contains t x] returns true iff [x] is contained in the
interval [t] *)
let contains t x =
match t with
| Empty -> false
| Interval (l,h) ->
Endpoint.compare x l >= 0 && Endpoint.compare x h <= 0
(** [intersect t1 t2] returns the intersection of the two input
intervals *)
let intersect t1 t2 =
let min x y = if Endpoint.compare x y <= 0 then x else y in
let max x y = if Endpoint.compare x y >= 0 then x else y in
match t1,t2 with
| Empty, _ | _, Empty -> Empty
| Interval (l1,h1), Interval (l2,h2) ->
create (max l1 l2) (min h1 h2)
end;;
#part 29
module Int_interval = Make_interval(Int) ;;
Int_interval.sexp_of_t (Int_interval.create 3 4);;
Int_interval.sexp_of_t (Int_interval.create 4 3);;
#part 30
#part 31
#part 32
#part 33
#part 34
#part 35
#part 36
#part 37
#part 38
#part 39
#part 40
#part 41
#part 42
#part 43
#part 44
#part 45
#part 46
#part 47
#part 48
#part 49
#part 50
#part 51
#part 52
#part 53
#part 54
#part 55
#part 56
#part 57
#part 58
#part 59
#part 60
#part 61
#part 62
#part 63
#part 64
#part 65
#part 66
#part 67
#part 68
#part 69
#part 70
#part 71
#part 72
#part 73
#part 74
#part 75
#part 76
#part 77
#part 78
#part 79
#part 80
#part 81
#part 82
#part 83
#part 84
#part 85
#part 86
#part 87
#part 88
#part 89
#part 90
#part 91
#part 92
#part 93
#part 94
#part 95
#part 96
#part 97
#part 98
#part 99
#part 100
================================================
FILE: code/functors/multi_sharing_constraint.syntax
================================================
with type = and =
================================================
FILE: code/functors/sexpable.ml
================================================
module type Sexpable = sig
type t
val sexp_of_t : t -> Sexp.t
val t_of_sexp : Sexp.t -> t
end
================================================
FILE: code/functors/sharing_constraint.syntax
================================================
with type =
================================================
FILE: code/gc/barrier_bench.ml
================================================
open Core.Std
open Core_bench.Std
type t1 = { mutable iters1: int; mutable count1: float }
type t2 = { iters2: int; count2: float }
let rec test_mutable t1 =
match t1.iters1 with
|0 -> ()
|_ ->
t1.iters1 <- t1.iters1 - 1;
t1.count1 <- t1.count1 +. 1.0;
test_mutable t1
let rec test_immutable t2 =
match t2.iters2 with
|0 -> ()
|n ->
let iters2 = n - 1 in
let count2 = t2.count2 +. 1.0 in
test_immutable { iters2; count2 }
let () =
let iters = 1000000 in
let tests = [
Bench.Test.create ~name:"mutable"
(fun () -> test_mutable { iters1=iters; count1=0.0 });
Bench.Test.create ~name:"immutable"
(fun () -> test_immutable { iters2=iters; count2=0.0 })
] in
Bench.make_command tests |> Command.run
================================================
FILE: code/gc/finalizer.ml
================================================
open Core.Std
open Async.Std
let attach_finalizer n v =
match Heap_block.create v with
| None -> printf "%20s: FAIL\n%!" n
| Some hb ->
let final _ = printf "%20s: OK\n%!" n in
Gc.add_finalizer hb final
type t = { foo: bool }
let main () =
let alloced_float = Unix.gettimeofday () in
let alloced_bool = alloced_float > 0.0 in
let alloced_string = String.create 4 in
attach_finalizer "immediate int" 1;
attach_finalizer "immediate float" 1.0;
attach_finalizer "immediate variant" (`Foo "hello");
attach_finalizer "immediate string" "hello world";
attach_finalizer "immediate record" { foo=false };
attach_finalizer "allocated float" alloced_float;
attach_finalizer "allocated bool" alloced_bool;
attach_finalizer "allocated variant" (`Foo alloced_bool);
attach_finalizer "allocated string" alloced_string;
attach_finalizer "allocated record" { foo=alloced_bool };
Gc.compact ();
return ()
let () =
Command.async_basic ~summary:"Testing finalizers"
Command.Spec.empty main
|> Command.run
================================================
FILE: code/gc/minor_heap.ascii
================================================
<---- size ---->
base --- start ---------------- end
limit ptr <------
blocks
================================================
FILE: code/gc/run_barrier_bench.sh
================================================
corebuild -pkg core_bench barrier_bench.native
./barrier_bench.native -ascii alloc
================================================
FILE: code/gc/run_finalizer.sh
================================================
corebuild -pkg async finalizer.native
./finalizer.native
================================================
FILE: code/gc/show_barrier_bench_help.sh
================================================
./barrier_bench.native -help
================================================
FILE: code/gc/tune.topscript
================================================
let c = Gc.get () ;;
Gc.tune ~minor_heap_size:(262144 * 2) () ;;
#part 1
Gc.tune ~major_heap_increment:(1000448 * 4) () ;;
#part 2
Gc.major_slice 0 ;;
Gc.full_major () ;;
#part 3
Gc.tune ~max_overhead:0 () ;;
================================================
FILE: code/guided-tour/build_sum.sh
================================================
corebuild sum.native
================================================
FILE: code/guided-tour/local_let.topscript
================================================
let x = 7 in
x + x
;;
#part 1
x;;
#part 2
let x = 7 in
let y = x * x in
x + y
;;
================================================
FILE: code/guided-tour/main.topscript
================================================
open Core.Std;;
#part 1
3 + 4;;
8 / 3;;
3.5 +. 6.;;
30_000_000 / 300_000;;
sqrt 9.;;
#part 2
let x = 3 + 4;;
let y = x + x;;
#part 3
let x7 = 3 + 4;;
let x_plus_y = x + y;;
let x' = x + 1;;
let _x' = x' + x';;
_x';;
#part 4
let Seven = 3 + 4;;
let 7x = 7;;
let x-plus-y = x + y;;
#part 5
let square x = x * x ;;
square 2;;
square (square 2);;
#part 6
let ratio x y =
Float.of_int x /. Float.of_int y
;;
ratio 4 7;;
#part 7
let sum_if_true test first second =
(if test first then first else 0)
+ (if test second then second else 0)
;;
#part 8
let even x =
x mod 2 = 0 ;;
sum_if_true even 3 4;;
sum_if_true even 2 4;;
#part 9
let sum_if_true (test : int -> bool) (x : int) (y : int) : int =
(if test x then x else 0)
+ (if test y then y else 0)
;;
#part 10
let first_if_true test x y =
if test x then x else y
;;
#part 11
let long_string s = String.length s > 6;;
first_if_true long_string "short" "loooooong";;
#part 12
let big_number x = x > 3;;
first_if_true big_number 4 3;;
#part 13
first_if_true big_number "short" "loooooong";;
#part 14
let add_potato x =
x + "potato";;
#part 15
let is_a_multiple x y =
x mod y = 0 ;;
is_a_multiple 8 2;;
is_a_multiple 8 0;;
#part 16
let a_tuple = (3,"three");;
let another_tuple = (3,"four",5.);;
#part 17
let (x,y) = a_tuple;;
#part 18
x + String.length y;;
#part 19
let distance (x1,y1) (x2,y2) =
sqrt ((x1 -. x2) ** 2. +. (y1 -. y2) ** 2.)
;;
#part 20
let languages = ["OCaml";"Perl";"C"];;
#part 21
let numbers = [3;"four";5];;
#part 22
List.length languages;;
#part 23
List.map languages ~f:String.length;;
#part 24
List.map ~f:String.length languages;;
#part 25
"French" :: "Spanish" :: languages;;
#part 26
languages;;
#part 27
["OCaml", "Perl", "C"];;
#part 28
1,2,3;;
#part 29
[1; 2; 3];;
1 :: (2 :: (3 :: []));;
1 :: 2 :: 3 :: [];;
#part 30
[1;2;3] @ [4;5;6];;
#part 31
let my_favorite_language (my_favorite :: the_rest) =
my_favorite
;;
#part 32
my_favorite_language ["English";"Spanish";"French"];;
my_favorite_language [];;
#part 33
let my_favorite_language languages =
match languages with
| first :: the_rest -> first
| [] -> "OCaml" (* A good default! *)
;;
my_favorite_language ["English";"Spanish";"French"];;
my_favorite_language [];;
#part 34
let rec sum l =
match l with
| [] -> 0 (* base case *)
| hd :: tl -> hd + sum tl (* inductive case *)
;;
sum [1;2;3];;
#part 35
let rec destutter list =
match list with
| [] -> []
| hd1 :: hd2 :: tl ->
if hd1 = hd2 then destutter (hd2 :: tl)
else hd1 :: destutter (hd2 :: tl)
;;
#part 36
let rec destutter list =
match list with
| [] -> []
| [hd] -> [hd]
| hd1 :: hd2 :: tl ->
if hd1 = hd2 then destutter (hd2 :: tl)
else hd1 :: destutter (hd2 :: tl)
;;
destutter ["hey";"hey";"hey";"man!"];;
#part 37
let divide x y =
if y = 0 then None else Some (x/y) ;;
#part 38
let log_entry maybe_time message =
let time =
match maybe_time with
| Some x -> x
| None -> Time.now ()
in
Time.to_sec_string time ^ " -- " ^ message
;;
log_entry (Some Time.epoch) "A long long time ago";;
log_entry None "Up to the minute";;
#part 39
let x = 7 in
x + x
;;
#part 40
let x = 7 in
let y = x * x in
x + y
;;
#part 41
type point2d = { x : float; y : float };;
#part 42
let p = { x = 3.; y = -4. };;
#part 43
let magnitude { x = x_pos; y = y_pos } =
sqrt (x_pos ** 2. +. y_pos ** 2.);;
#part 44
let magnitude { x; y } = sqrt (x ** 2. +. y ** 2.);;
#part 45
let distance v1 v2 =
magnitude { x = v1.x -. v2.x; y = v1.y -. v2.y };;
#part 46
type circle_desc = { center: point2d; radius: float }
type rect_desc = { lower_left: point2d; width: float; height: float }
type segment_desc = { endpoint1: point2d; endpoint2: point2d } ;;
#part 47
type scene_element =
| Circle of circle_desc
| Rect of rect_desc
| Segment of segment_desc
;;
#part 48
let is_inside_scene_element point scene_element =
match scene_element with
| Circle { center; radius } ->
distance center point < radius
| Rect { lower_left; width; height } ->
point.x > lower_left.x && point.x < lower_left.x +. width
&& point.y > lower_left.y && point.y < lower_left.y +. height
| Segment { endpoint1; endpoint2 } -> false
;;
let is_inside_scene point scene =
List.exists scene
~f:(fun el -> is_inside_scene_element point el)
;;
is_inside_scene {x=3.;y=7.}
[ Circle {center = {x=4.;y= 4.}; radius = 0.5 } ];;
is_inside_scene {x=3.;y=7.}
[ Circle {center = {x=4.;y= 4.}; radius = 5.0 } ];;
#part 49
let numbers = [| 1; 2; 3; 4 |];;
numbers.(2) <- 4;;
numbers;;
#part 50
type running_sum =
{ mutable sum: float;
mutable sum_sq: float; (* sum of squares *)
mutable samples: int;
}
;;
#part 51
let mean rsum = rsum.sum /. float rsum.samples
let stdev rsum =
sqrt (rsum.sum_sq /. float rsum.samples
-. (rsum.sum /. float rsum.samples) ** 2.) ;;
#part 52
let create () = { sum = 0.; sum_sq = 0.; samples = 0 }
let update rsum x =
rsum.samples <- rsum.samples + 1;
rsum.sum <- rsum.sum +. x;
rsum.sum_sq <- rsum.sum_sq +. x *. x
;;
#part 53
let rsum = create ();;
List.iter [1.;3.;2.;-7.;4.;5.] ~f:(fun x -> update rsum x);;
mean rsum;;
stdev rsum;;
#part 54
let x = { contents = 0 };;
x.contents <- x.contents + 1;;
x;;
#part 55
let x = ref 0 (* create a ref, i.e., { contents = 0 } *) ;;
!x (* get the contents of a ref, i.e., x.contents *) ;;
x := !x + 1 (* assignment, i.e., x.contents <- ... *) ;;
!x ;;
#part 56
type 'a ref = { mutable contents : 'a }
let ref x = { contents = x }
let (!) r = r.contents
let (:=) r x = r.contents <- x
;;
#part 57
let sum list =
let sum = ref 0 in
List.iter list ~f:(fun x -> sum := !sum + x);
!sum
;;
#part 58
let permute array =
let length = Array.length array in
for i = 0 to length - 2 do
(* pick a j that is after i and before the end of the array *)
let j = i + 1 + Random.int (length - i - 1) in
(* Swap i and j *)
let tmp = array.(i) in
array.(i) <- array.(j);
array.(j) <- tmp
done
;;
#part 59
let ar = Array.init 20 ~f:(fun i -> i);;
permute ar;;
ar;;
#part 60
let find_first_negative_entry array =
let pos = ref 0 in
while !pos < Array.length array && array.(!pos) >= 0 do
pos := !pos + 1
done;
if !pos = Array.length array then None else Some !pos
;;
find_first_negative_entry [|1;2;0;3|];;
find_first_negative_entry [|1;-2;0;3|];;
#part 61
let find_first_negative_entry array =
let pos = ref 0 in
while
let pos_is_good = !pos < Array.length array in
let element_is_non_negative = array.(!pos) >= 0 in
pos_is_good && element_is_non_negative
do
pos := !pos + 1
done;
if !pos = Array.length array then None else Some !pos
;;
find_first_negative_entry [|1;2;0;3|];;
#part 62
#part 63
================================================
FILE: code/guided-tour/recursion.ml
================================================
sum [1;2;3]
= 1 + sum [2;3]
= 1 + (2 + sum [3])
= 1 + (2 + (3 + sum []))
= 1 + (2 + (3 + 0))
= 1 + (2 + 3)
= 1 + 5
= 6
================================================
FILE: code/guided-tour/run_sum.sh
================================================
./sum.native
================================================
FILE: code/guided-tour/sum.ml
================================================
open Core.Std
let rec read_and_accumulate accum =
let line = In_channel.input_line In_channel.stdin in
match line with
| None -> accum
| Some x -> read_and_accumulate (accum +. Float.of_string x)
let () =
printf "Total: %F\n" (read_and_accumulate 0.)
================================================
FILE: code/guided-tour/sum.rawsh
================================================
$ ./sum.native
1
2
3
94.5
Total: 100.5
================================================
FILE: code/imperative-programming/.gitignore
================================================
numbers.txt
================================================
FILE: code/imperative-programming/array-get.syntax
================================================
.()
================================================
FILE: code/imperative-programming/array-set.syntax
================================================
.() <-
================================================
FILE: code/imperative-programming/bigarray.syntax
================================================
.{}
.{} <-
================================================
FILE: code/imperative-programming/build_all.sh
================================================
corebuild dictionary.cmo
corebuild dlist.cmo
corebuild time_converter.byte
corebuild time_converter2.byte
================================================
FILE: code/imperative-programming/dictionary.ml
================================================
(* part 1 *)
(* file: dictionary.ml *)
open Core.Std
type ('a, 'b) t = { mutable length: int;
buckets: ('a * 'b) list array;
}
(* part 2 *)
let num_buckets = 17
let hash_bucket key = (Hashtbl.hash key) mod num_buckets
let create () =
{ length = 0;
buckets = Array.create ~len:num_buckets [];
}
let length t = t.length
let find t key =
List.find_map t.buckets.(hash_bucket key)
~f:(fun (key',data) -> if key' = key then Some data else None)
(* part 3 *)
let iter t ~f =
for i = 0 to Array.length t.buckets - 1 do
List.iter t.buckets.(i) ~f:(fun (key, data) -> f ~key ~data)
done
(* part 4 *)
let bucket_has_key t i key =
List.exists t.buckets.(i) ~f:(fun (key',_) -> key' = key)
let add t ~key ~data =
let i = hash_bucket key in
let replace = bucket_has_key t i key in
let filtered_bucket =
if replace then
List.filter t.buckets.(i) ~f:(fun (key',_) -> key' <> key)
else
t.buckets.(i)
in
t.buckets.(i) <- (key, data) :: filtered_bucket;
if not replace then t.length <- t.length + 1
let remove t key =
let i = hash_bucket key in
if bucket_has_key t i key then (
let filtered_bucket =
List.filter t.buckets.(i) ~f:(fun (key',_) -> key' <> key)
in
t.buckets.(i) <- filtered_bucket;
t.length <- t.length - 1
)
================================================
FILE: code/imperative-programming/dictionary.mli
================================================
(* part 1 *)
(* file: dictionary.mli *)
open Core.Std
type ('a, 'b) t
val create : unit -> ('a, 'b) t
val length : ('a, 'b) t -> int
val add : ('a, 'b) t -> key:'a -> data:'b -> unit
val find : ('a, 'b) t -> 'a -> 'b option
val iter : ('a, 'b) t -> f:(key:'a -> data:'b -> unit) -> unit
val remove : ('a, 'b) t -> 'a -> unit
================================================
FILE: code/imperative-programming/dictionary2.ml
================================================
open Core.Std
type ('a, 'b) t = { mutable length: int;
buckets: ('a * 'b) list array;
}
let num_buckets = 17
let hash_bucket key = (Hashtbl.hash key) mod num_buckets
let create () =
{ length = 0;
buckets = Array.create ~len:num_buckets [];
}
let length t = t.length
let find t key =
List.find_map t.buckets.(hash_bucket key)
~f:(fun (key',data) -> if key' = key then Some data else None)
let iter t ~f =
for i = 0 to Array.length t.buckets - 1 do
List.iter t.buckets.(i) ~f:(fun (key, data) -> f ~key ~data)
done
let bucket_has_key t i key =
List.exists t.buckets.(i) ~f:(fun (key',_) -> key' = key)
let add t ~key ~data =
let i = hash_bucket key in
let replace = bucket_has_key t i key in
let filtered_bucket =
if replace then
List.filter t.buckets.(i) ~f:(fun (key',_) -> key' <> key)
else
t.buckets.(i)
in
(* part 1 *)
let () = t.buckets.(i) <- (key, data) :: filtered_bucket in
if not replace then t.length <- t.length + 1
(* part 2 *)
let remove t key =
let i = hash_bucket key in
if bucket_has_key t i key then (
let filtered_bucket =
List.filter t.buckets.(i) ~f:(fun (key',_) -> key' <> key)
in
t.buckets.(i) <- filtered_bucket;
t.length <- t.length - 1
)
================================================
FILE: code/imperative-programming/dlist.ml
================================================
(* part 1 *)
(* file: dlist.ml *)
open Core.Std
type 'a element =
{ value : 'a;
mutable next : 'a element option;
mutable prev : 'a element option
}
type 'a t = 'a element option ref
(* part 2 *)
let create () = ref None
let is_empty t = !t = None
let value elt = elt.value
let first t = !t
let next elt = elt.next
let prev elt = elt.prev
(* part 3 *)
let insert_first t value =
let new_elt = { prev = None; next = !t; value } in
begin match !t with
| Some old_first -> old_first.prev <- Some new_elt
| None -> ()
end;
t := Some new_elt;
new_elt
(* part 4 *)
let insert_after elt value =
let new_elt = { value; prev = Some elt; next = elt.next } in
begin match elt.next with
| Some old_next -> old_next.prev <- Some new_elt
| None -> ()
end;
elt.next <- Some new_elt;
new_elt
(* part 5 *)
let remove t elt =
let { prev; next; _ } = elt in
begin match prev with
| Some prev -> prev.next <- next
| None -> t := next
end;
begin match next with
| Some next -> next.prev <- prev;
| None -> ()
end;
elt.prev <- None;
elt.next <- None
(* part 6 *)
let iter t ~f =
let rec loop = function
| None -> ()
| Some el -> f (value el); loop (next el)
in
loop !t
let find_el t ~f =
let rec loop = function
| None -> None
| Some elt ->
if f (value elt) then Some elt
else loop (next elt)
in
loop !t
================================================
FILE: code/imperative-programming/dlist.mli
================================================
(* file: dlist.mli *)
open Core.Std
type 'a t
type 'a element
(** Basic list operations *)
val create : unit -> 'a t
val is_empty : 'a t -> bool
(** Navigation using [element]s *)
val first : 'a t -> 'a element option
val next : 'a element -> 'a element option
val prev : 'a element -> 'a element option
val value : 'a element -> 'a
(** Whole-data-structure iteration *)
val iter : 'a t -> f:('a -> unit) -> unit
val find_el : 'a t -> f:('a -> bool) -> 'a element option
(** Mutation *)
val insert_first : 'a t -> 'a -> 'a element
val insert_after : 'a element -> 'a -> 'a element
val remove : 'a t -> 'a element -> unit
================================================
FILE: code/imperative-programming/edit_distance.ascii
================================================
edit_distance "OCam" "ocaml"
edit_distance "OCaml" "ocam"
edit_distance "OCam" "ocam"
================================================
FILE: code/imperative-programming/edit_distance2.ascii
================================================
edit_distance "OCam" "ocaml"
edit_distance "OCa" "ocaml"
edit_distance "OCam" "ocam"
edit_distance "OCa" "ocam"
edit_distance "OCaml" "ocam"
edit_distance "OCam" "ocam"
edit_distance "OCaml" "oca"
edit_distance "OCam" "oca"
edit_distance "OCam" "ocam"
edit_distance "OCa" "ocam"
edit_distance "OCam" "oca"
edit_distance "OCa" "oca"
================================================
FILE: code/imperative-programming/examples.topscript
================================================
1;;
#part 1
List.find_map;;
#part 2
let rec endless_loop = 1 :: 2 :: 3 :: endless_loop;;
================================================
FILE: code/imperative-programming/fib.topscript
================================================
let time f =
let start = Time.now () in
let x = f () in
let stop = Time.now () in
printf "Time: %s\n" (Time.Span.to_string (Time.diff stop start));
x ;;
let memoize f =
let table = Hashtbl.Poly.create () in
(fun x ->
match Hashtbl.find table x with
| Some y -> y
| None ->
let y = f x in
Hashtbl.add_exn table ~key:x ~data:y;
y
);;
#part 1
let rec fib i =
if i <= 1 then 1 else fib (i - 1) + fib (i - 2);;
#part 2
time (fun () -> fib 20);;
time (fun () -> fib 40);;
#part 3
let fib = memoize fib;;
time (fun () -> fib 40);;
time (fun () -> fib 40);;
#part 4
let fib_norec fib i =
if i <= 1 then i
else fib (i - 1) + fib (i - 2) ;;
#part 5
let rec fib i = fib_norec fib i;;
fib 20;;
#part 6
let make_rec f_norec =
let rec f x = f_norec f x in
f
;;
let fib = make_rec fib_norec;;
fib 20;;
#part 7
let memo_rec f_norec x =
let fref = ref (fun _ -> assert false) in
let f = memoize (fun x -> f_norec !fref x) in
fref := f;
f x
;;
#part 8
let fib = memo_rec fib_norec;;
time (fun () -> fib 40);;
#part 9
let fib = memo_rec (fun fib i ->
if i <= 1 then 1 else fib (i - 1) + fib (i - 2));;
================================================
FILE: code/imperative-programming/file.topscript
================================================
1;;
#part 1
let create_number_file filename numbers =
let outc = Out_channel.create filename in
List.iter numbers ~f:(fun x -> fprintf outc "%d\n" x);
Out_channel.close outc
;;
let sum_file filename =
let file = In_channel.create filename in
let numbers = List.map ~f:Int.of_string (In_channel.input_lines file) in
let sum = List.fold ~init:0 ~f:(+) numbers in
In_channel.close file;
sum
;;
create_number_file "numbers.txt" [1;2;3;4;5];;
sum_file "numbers.txt";;
#part 2
sum_file "/etc/hosts";;
#part 3
for i = 1 to 10000 do try ignore (sum_file "/etc/hosts") with _ -> () done;;
sum_file "numbers.txt";;
================================================
FILE: code/imperative-programming/file2.topscript
================================================
1;;
#part 1
let sum_file filename =
let file = In_channel.create filename in
protect ~f:(fun () ->
let numbers = List.map ~f:Int.of_string (In_channel.input_lines file) in
List.fold ~init:0 ~f:(+) numbers)
~finally:(fun () -> In_channel.close file)
;;
#part 2
for i = 1 to 10000 do try ignore (sum_file "/etc/hosts") with _ -> () done;;
sum_file "numbers.txt";;
#part 3
let sum_file filename =
In_channel.with_file filename ~f:(fun file ->
let numbers = List.map ~f:Int.of_string (In_channel.input_lines file) in
List.fold ~init:0 ~f:(+) numbers)
;;
#part 4
let sum_file filename =
In_channel.with_file filename ~f:(fun file ->
In_channel.fold_lines file ~init:0 ~f:(fun sum line ->
sum + Int.of_string line))
;;
================================================
FILE: code/imperative-programming/for.topscript
================================================
1;;
#part 1
for i = 0 to 3 do printf "i = %d\n" i done;;
#part 2
for i = 3 downto 0 do printf "i = %d\n" i done;;
#part 3
let rev_inplace ar =
let i = ref 0 in
let j = ref (Array.length ar - 1) in
(* terminate when the upper and lower indices meet *)
while !i < !j do
(* swap the two elements *)
let tmp = ar.(!i) in
ar.(!i) <- ar.(!j);
ar.(!j) <- tmp;
(* bump the indices *)
incr i;
decr j
done
;;
let nums = [|1;2;3;4;5|];;
rev_inplace nums;;
nums;;
================================================
FILE: code/imperative-programming/lazy.topscript
================================================
1;;
#part 1
let v = lazy (print_string "performing lazy computation\n"; sqrt 16.);;
Lazy.force v;;
Lazy.force v;;
#part 2
type 'a lazy_state =
| Delayed of (unit -> 'a)
| Value of 'a
| Exn of exn
;;
#part 3
let create_lazy f = ref (Delayed f);;
let v = create_lazy
(fun () -> print_string "performing lazy computation\n"; sqrt 16.);;
#part 4
let force v =
match !v with
| Value x -> x
| Exn e -> raise e
| Delayed f ->
try
let x = f () in
v := Value x;
x
with exn ->
v := Exn exn;
raise exn
;;
#part 5
force v;;
force v;;
================================================
FILE: code/imperative-programming/let-unit.syntax
================================================
let () = in
let () = in
...
================================================
FILE: code/imperative-programming/let_rec.ml
================================================
let rec x = x + 1
================================================
FILE: code/imperative-programming/letrec.topscript
================================================
let time f =
let start = Time.now () in
let x = f () in
let stop = Time.now () in
printf "Time: %s\n" (Time.Span.to_string (Time.diff stop start));
x ;;
let memoize f =
let table = Hashtbl.Poly.create () in
(fun x ->
match Hashtbl.find table x with
| Some y -> y
| None ->
let y = f x in
Hashtbl.add_exn table ~key:x ~data:y;
y
);;
#part 1
let memo_rec f_norec =
let rec f = memoize (fun x -> f_norec f x) in
f
;;
#part 2
let rec x = lazy (Lazy.force x + 1);;
#part 3
Lazy.force x;;
#part 4
let fib_norec fib i =
if i <= 1 then i
else fib (i - 1) + fib (i - 2) ;;
#part 5
let lazy_memo_rec f_norec x =
let rec f = lazy (memoize (fun x -> f_norec (Lazy.force f) x)) in
(Lazy.force f) x
;;
time (fun () -> lazy_memo_rec fib_norec 40);;
================================================
FILE: code/imperative-programming/memo.topscript
================================================
1;;
#part 1
let memoize f =
let table = Hashtbl.Poly.create () in
(fun x ->
match Hashtbl.find table x with
| Some y -> y
| None ->
let y = f x in
Hashtbl.add_exn table ~key:x ~data:y;
y
);;
#part 2
let rec edit_distance s t =
match String.length s, String.length t with
| (0,x) | (x,0) -> x
| (len_s,len_t) ->
let s' = String.drop_suffix s 1 in
let t' = String.drop_suffix t 1 in
let cost_to_drop_both =
if s.[len_s - 1] = t.[len_t - 1] then 0 else 1
in
List.reduce_exn ~f:Int.min
[ edit_distance s' t + 1
; edit_distance s t' + 1
; edit_distance s' t' + cost_to_drop_both
]
;;
edit_distance "OCaml" "ocaml";;
#part 3
let time f =
let start = Time.now () in
let x = f () in
let stop = Time.now () in
printf "Time: %s\n" (Time.Span.to_string (Time.diff stop start));
x ;;
#part 4
time (fun () -> edit_distance "OCaml" "ocaml");;
time (fun () -> edit_distance "OCaml 4.01" "ocaml 4.01");;
#part 5
let memo_rec f_norec x =
let fref = ref (fun _ -> assert false) in
let f = memoize (fun x -> f_norec !fref x) in
fref := f;
f x
;;
#part 6
let edit_distance = memo_rec (fun edit_distance (s,t) ->
match String.length s, String.length t with
| (0,x) | (x,0) -> x
| (len_s,len_t) ->
let s' = String.drop_suffix s 1 in
let t' = String.drop_suffix t 1 in
let cost_to_drop_both =
if s.[len_s - 1] = t.[len_t - 1] then 0 else 1
in
List.reduce_exn ~f:Int.min
[ edit_distance (s',t ) + 1
; edit_distance (s ,t') + 1
; edit_distance (s',t') + cost_to_drop_both
]) ;;
#part 7
time (fun () -> edit_distance ("OCaml 4.01","ocaml 4.01"));;
================================================
FILE: code/imperative-programming/order.topscript
================================================
1;;
#part 1
let x = sin 120. in
let y = sin 75. in
let z = sin 128. in
List.exists ~f:(fun x -> x < 0.) [x;y;z]
;;
#part 2
let x = lazy (sin 120.) in
let y = lazy (sin 75.) in
let z = lazy (sin 128.) in
List.exists ~f:(fun x -> Lazy.force x < 0.) [x;y;z]
;;
#part 3
let x = lazy (printf "1\n"; sin 120.) in
let y = lazy (printf "2\n"; sin 75.) in
let z = lazy (printf "3\n"; sin 128.) in
List.exists ~f:(fun x -> Lazy.force x < 0.) [x;y;z]
;;
#part 4
List.exists ~f:(fun x -> x < 0.)
[ (printf "1\n"; sin 120.);
(printf "2\n"; sin 75.);
(printf "3\n"; sin 128.); ]
;;
================================================
FILE: code/imperative-programming/printf.topscript
================================================
open Printf
1;;
#part 1
printf "%i is an integer, %F is a float, \"%s\" is a string\n"
3 4.5 "five";;
#part 2
printf "An integer: %i\n" 4.5;;
#part 3
let fmt = "%i is an integer, %F is a float, \"%s\" is a string\n";;
printf fmt 3 4.5 "five";;
#part 4
let fmt : ('a, 'b, 'c) format =
"%i is an integer, %F is a float, \"%s\" is a string\n";;
#part 5
printf fmt 3 4.5 "five";;
================================================
FILE: code/imperative-programming/ref.topscript
================================================
1;;
#part 1
type 'a ref = { mutable contents : 'a };;
#part 2
let ref x = { contents = x };;
let (!) r = r.contents;;
let (:=) r x = r.contents <- x;;
#part 3
let x = ref 1;;
!x;;
x := !x + 1;;
!x;;
================================================
FILE: code/imperative-programming/remember_type.ml
================================================
val remember : '_a -> '_a =
================================================
FILE: code/imperative-programming/semicolon-syntax.syntax
================================================
;
;
...
================================================
FILE: code/imperative-programming/semicolon.syntax
================================================
;
;
...
================================================
FILE: code/imperative-programming/string.syntax
================================================
.[]
.[] <-
================================================
FILE: code/imperative-programming/time_converter.ml
================================================
open Core.Std
let () =
Out_channel.output_string stdout "Pick a timezone: ";
Out_channel.flush stdout;
match In_channel.input_line stdin with
| None -> failwith "No timezone provided"
| Some zone_string ->
let zone = Zone.find_exn zone_string in
let time_string = Time.to_string_abs (Time.now ()) ~zone in
Out_channel.output_string stdout
(String.concat
["The time in ";Zone.to_string zone;" is ";time_string;".\n"]);
Out_channel.flush stdout
================================================
FILE: code/imperative-programming/time_converter.rawsh
================================================
$ corebuild time_converter.byte
$ ./time_converter.byte
Pick a timezone:
================================================
FILE: code/imperative-programming/time_converter2.ml
================================================
open Core.Std
let () =
printf "Pick a timezone: %!";
match In_channel.input_line stdin with
| None -> failwith "No timezone provided"
| Some zone_string ->
let zone = Time.Zone.find_exn zone_string in
let time_string = Time.to_string_abs (Time.now ()) ~zone in
printf "The time in %s is %s.\n%!" (Time.Zone.to_string zone) time_string
================================================
FILE: code/imperative-programming/time_converter2.rawsh
================================================
Pick a timezone: Europe/London
The time in Europe/London is 2013-08-15 00:03:10.666220+01:00.
================================================
FILE: code/imperative-programming/value_restriction-13.rawscript
================================================
# module Concat_list : sig
type 'a t
val empty : 'a t
val singleton : 'a -> 'a t
val concat : 'a t -> 'a t -> 'a t (* constant time *)
val to_list : 'a t -> 'a list (* linear time *)
end = struct
type 'a t = Empty | Singleton of 'a | Concat of 'a t * 'a t
...
end;;
module Concat_list :
sig
type 'a t
val empty : 'a t
val singleton : 'a -> 'a t
val concat : 'a t -> 'a t -> 'a t
val to_list : 'a t -> 'a list
end
================================================
FILE: code/imperative-programming/value_restriction.topscript
================================================
let identity x = x;;
let time f =
let start = Time.now () in
let x = f () in
let stop = Time.now () in
printf "Time: %s\n" (Time.Span.to_string (Time.diff stop start));
x ;;
let memoize f =
let table = Hashtbl.Poly.create () in
(fun x ->
match Hashtbl.find table x with
| Some y -> y
| None ->
let y = f x in
Hashtbl.add_exn table ~key:x ~data:y;
y
);;
#part 1
(fun x -> [x;x]);;
#part 2
memoize (fun x -> [x;x]);;
#part 3
identity (fun x -> [x;x]);;
#part 4
let f () = ref None;;
#part 5
List.init;;
List.init 10 ~f:Int.to_string;;
#part 6
let list_init_10 = List.init 10;;
#part 7
let list_init_10 ~f = List.init 10 ~f;;
#part 8
identity (fun x -> [x;x]);;
#part 9
identity [];;
#part 10
[||];;
identity [||];;
#part 11
module Concat_list : sig
type 'a t
val empty : 'a t
val singleton : 'a -> 'a t
val concat : 'a t -> 'a t -> 'a t (* constant time *)
val to_list : 'a t -> 'a list (* linear time *)
end = struct
type 'a t = Empty | Singleton of 'a | Concat of 'a t * 'a t
let empty = Empty
let singleton x = Singleton x
let concat x y = Concat (x,y)
let rec to_list_with_tail t tail =
match t with
| Empty -> tail
| Singleton x -> x :: tail
| Concat (x,y) -> to_list_with_tail x (to_list_with_tail y tail)
let to_list t =
to_list_with_tail t []
end;;
#part 12
Concat_list.empty;;
identity Concat_list.empty;;
#part 13
module Concat_list : sig
type +'a t
val empty : 'a t
val singleton : 'a -> 'a t
val concat : 'a t -> 'a t -> 'a t (* constant time *)
val to_list : 'a t -> 'a list (* linear time *)
end = struct
type 'a t = Empty | Singleton of 'a | Concat of 'a t * 'a t
let empty = Empty
let singleton x = Singleton x
let concat x y = Concat (x,y)
let rec to_list_with_tail t tail =
match t with
| Empty -> tail
| Singleton x -> x :: tail
| Concat (x,y) -> to_list_with_tail x (to_list_with_tail y tail)
let to_list t =
to_list_with_tail t []
end;;
#part 14
identity Concat_list.empty;;
================================================
FILE: code/imperative-programming/weak.topscript
================================================
1;;
#part 1
let remember =
let cache = ref None in
(fun x ->
match !cache with
| Some y -> y
| None -> cache := Some x; x)
;;
#part 2
let identity x = x;;
identity 3;;
identity "five";;
#part 3
let remember_three () = remember 3;;
remember;;
remember "avocado";;
================================================
FILE: code/installation/arch_install.rawsh
================================================
# pacman -Sy ocaml
================================================
FILE: code/installation/arch_opam.rawsh
================================================
$ sudo pacman -Sy base-devel
$ wget https://aur.archlinux.org/packages/op/opam/opam.tar.gz
$ tar -xvf opam.tar.gz && cd opam
$ makepkg
$ sudo pacman -U opam-.tar.gz
================================================
FILE: code/installation/brew_install.rawsh
================================================
$ brew update
$ brew install ocaml
$ brew install pcre
================================================
FILE: code/installation/brew_opam_install.rawsh
================================================
$ brew update
$ brew install opam
================================================
FILE: code/installation/debian_apt.rawsh
================================================
# apt-get install \
ocaml ocaml-native-compilers camlp4-extra \
git libpcre3-dev curl build-essential m4
================================================
FILE: code/installation/debian_apt_opam.rawsh
================================================
# apt-get update
# apt-get -t unstable install opam
================================================
FILE: code/installation/emacsrc.scm
================================================
(autoload 'utop "utop" "Toplevel for OCaml" t)
================================================
FILE: code/installation/fedora_install.rawsh
================================================
# yum install ocaml
# yum install ocaml-camlp4-devel
# yum install pcre-devel
================================================
FILE: code/installation/macports_install.rawsh
================================================
$ sudo port install ocaml
$ sudo port install ocaml-pcre
================================================
FILE: code/installation/macports_opam_install.rawsh
================================================
$ sudo port install opam
================================================
FILE: code/installation/ocaml_src_install.rawsh
================================================
$ curl -OL https://github.com/ocaml/ocaml/archive/4.01.tar.gz
$ tar -zxvf 4.01.tar.gz
$ cd ocaml-4.01
$ ./configure
$ make world world.opt
$ sudo make install
================================================
FILE: code/installation/ocaml_user_conf.rawsh
================================================
$ ./configure -prefix $HOME/my-ocaml
================================================
FILE: code/installation/opam_eval.rawsh
================================================
$ eval `opam config env`
================================================
FILE: code/installation/opam_init.rawsh
================================================
$ opam init
<...>
=-=-=-= Configuring OPAM =-=-=-=
Do you want to update your configuration to use OPAM ? [Y/n] y
[1/4] Do you want to update your shell configuration file ? [default: ~/.profile] y
[2/4] Do you want to update your ~/.ocamlinit ? [Y/n] y
[3/4] Do you want to install the auto-complete scripts ? [Y/n] y
[4/4] Do you want to install the `opam-switch-eval` script ? [Y/n] y
User configuration:
~/.ocamlinit is already up-to-date.
~/.profile is already up-to-date.
Gloabal configuration:
Updating /opam-init/init.sh
auto-completion : [true]
opam-switch-eval: [true]
Updating /opam-init/init.zsh
auto-completion : [true]
opam-switch-eval: [true]
Updating /opam-init/init.csh
auto-completion : [true]
opam-switch-eval: [true]
================================================
FILE: code/installation/opam_install.rawsh
================================================
$ opam install core core_extended core_bench async
================================================
FILE: code/installation/opam_install_utop.rawsh
================================================
$ opam install utop
================================================
FILE: code/installation/opam_list.rawsh
================================================
$ opam list
Installed packages for 4.01.0:
async 109.38.00 Monadic concurrency library
async_core 109.38.00 Monadic concurrency library
async_extra 109.38.00 Monadic concurrency library
<...>
================================================
FILE: code/installation/opam_switch.rawsh
================================================
$ opam switch 4.01.0dev+trunk
$ eval `opam config env`
================================================
FILE: code/installation/open_core.ml
================================================
open Core.Std
================================================
FILE: code/installation/show_ocamlinit.rawsh
================================================
$ cat ~/.ocamlinit
#use "topfind"
#thread
#camlp4o
#require "core.top"
#require "core.syntax"
================================================
FILE: code/installation/ubuntu_opam_ppa.rawsh
================================================
$ add-apt-repository ppa:avsm/ppa
$ apt-get update
$ apt-get install ocaml opam
================================================
FILE: code/json/_tags
================================================
true: -warn_32
================================================
FILE: code/json/book.json
================================================
{
"title": "Real World OCaml",
"tags" : [ "functional programming", "ocaml", "algorithms" ],
"pages": 450,
"authors": [
{ "name": "Jason Hickey", "affiliation": "Google" },
{ "name": "Anil Madhavapeddy", "affiliation": "Cambridge"},
{ "name": "Yaron Minsky", "affiliation": "Jane Street"}
],
"is_online": true
}
================================================
FILE: code/json/build_github_atd.sh
================================================
atdgen -t github.atd
atdgen -j github.atd
ocamlfind ocamlc -package atd -i github_t.mli
================================================
FILE: code/json/build_github_org.sh
================================================
atdgen -t github_org.atd
atdgen -j github_org.atd
corebuild -pkg core_extended,yojson,atdgen github_org_info.native
================================================
FILE: code/json/build_json.topscript
================================================
#require "yojson" ;;
open Core.Std ;;
#part 1
let person = `Assoc [ ("name", `String "Anil") ] ;;
#part 2
Yojson.Basic.pretty_to_string ;;
#part 3
Yojson.Basic.pretty_to_string person ;;
Yojson.Basic.pretty_to_channel stdout person ;;
#part 4
let person = `Assoc ("name", `String "Anil");;
Yojson.Basic.pretty_to_string person ;;
#part 5
let (person : Yojson.Basic.json) =
`Assoc ("name", `String "Anil");;
================================================
FILE: code/json/generate_github_org_json.sh
================================================
atdgen -j github_org.atd
cat github_org_j.mli
================================================
FILE: code/json/generate_github_org_types.sh
================================================
atdgen -t github_org.atd
cat github_org_t.mli
================================================
FILE: code/json/github.atd
================================================
type scope = [
User
| Public_repo
| Repo
| Repo_status
| Delete_repo
| Gist
]
type app = {
name: string;
url: string;
}
type authorization_request = {
scopes: scope list;
note: string;
}
type authorization_response = {
scopes: scope list;
token: string;
app: app;
url: string;
id: int;
?note: string option;
?note_url: string option;
}
================================================
FILE: code/json/github_j.ml
================================================
(* Auto-generated from "github.atd" *)
type scope = Github_t.scope
type app = Github_t.app = {
app_name (*atd name *): string;
app_url (*atd url *): string
}
type authorization_request = Github_t.authorization_request = {
auth_req_scopes (*atd scopes *): scope list;
auth_req_note (*atd note *): string
}
type authorization_response = Github_t.authorization_response = {
scopes: scope list;
token: string;
app: app;
url: string;
id: int;
note: string option;
note_url: string option
}
let write_scope = (
fun ob x ->
match x with
| `User -> Bi_outbuf.add_string ob "<\"user\">"
| `Public_repo -> Bi_outbuf.add_string ob "<\"public_repo\">"
| `Repo -> Bi_outbuf.add_string ob "<\"repo\">"
| `Repo_status -> Bi_outbuf.add_string ob "<\"repo_status\">"
| `Delete_repo -> Bi_outbuf.add_string ob "<\"delete_repo\">"
| `Gist -> Bi_outbuf.add_string ob "<\"gist\">"
)
let string_of_scope ?(len = 1024) x =
let ob = Bi_outbuf.create len in
write_scope ob x;
Bi_outbuf.contents ob
let read_scope = (
fun p lb ->
Yojson.Safe.read_space p lb;
match Yojson.Safe.start_any_variant p lb with
| `Edgy_bracket -> (
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
try
match len with
| 4 -> (
match String.unsafe_get s pos with
| 'g' -> (
if String.unsafe_get s (pos+1) = 'i' && String.unsafe_get s (pos+2) = 's' && String.unsafe_get s (pos+3) = 't' then (
5
)
else (
raise (Exit)
)
)
| 'r' -> (
if String.unsafe_get s (pos+1) = 'e' && String.unsafe_get s (pos+2) = 'p' && String.unsafe_get s (pos+3) = 'o' then (
2
)
else (
raise (Exit)
)
)
| 'u' -> (
if String.unsafe_get s (pos+1) = 's' && String.unsafe_get s (pos+2) = 'e' && String.unsafe_get s (pos+3) = 'r' then (
0
)
else (
raise (Exit)
)
)
| _ -> (
raise (Exit)
)
)
| 11 -> (
match String.unsafe_get s pos with
| 'd' -> (
if String.unsafe_get s (pos+1) = 'e' && String.unsafe_get s (pos+2) = 'l' && String.unsafe_get s (pos+3) = 'e' && String.unsafe_get s (pos+4) = 't' && String.unsafe_get s (pos+5) = 'e' && String.unsafe_get s (pos+6) = '_' && String.unsafe_get s (pos+7) = 'r' && String.unsafe_get s (pos+8) = 'e' && String.unsafe_get s (pos+9) = 'p' && String.unsafe_get s (pos+10) = 'o' then (
4
)
else (
raise (Exit)
)
)
| 'p' -> (
if String.unsafe_get s (pos+1) = 'u' && String.unsafe_get s (pos+2) = 'b' && String.unsafe_get s (pos+3) = 'l' && String.unsafe_get s (pos+4) = 'i' && String.unsafe_get s (pos+5) = 'c' && String.unsafe_get s (pos+6) = '_' && String.unsafe_get s (pos+7) = 'r' && String.unsafe_get s (pos+8) = 'e' && String.unsafe_get s (pos+9) = 'p' && String.unsafe_get s (pos+10) = 'o' then (
1
)
else (
raise (Exit)
)
)
| 'r' -> (
if String.unsafe_get s (pos+1) = 'e' && String.unsafe_get s (pos+2) = 'p' && String.unsafe_get s (pos+3) = 'o' && String.unsafe_get s (pos+4) = '_' && String.unsafe_get s (pos+5) = 's' && String.unsafe_get s (pos+6) = 't' && String.unsafe_get s (pos+7) = 'a' && String.unsafe_get s (pos+8) = 't' && String.unsafe_get s (pos+9) = 'u' && String.unsafe_get s (pos+10) = 's' then (
3
)
else (
raise (Exit)
)
)
| _ -> (
raise (Exit)
)
)
| _ -> (
raise (Exit)
)
with Exit -> (
Ag_oj_run.invalid_variant_tag (String.sub s pos len)
)
in
let i = Yojson.Safe.map_ident p f lb in
match i with
| 0 ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_gt p lb;
`User
| 1 ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_gt p lb;
`Public_repo
| 2 ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_gt p lb;
`Repo
| 3 ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_gt p lb;
`Repo_status
| 4 ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_gt p lb;
`Delete_repo
| 5 ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_gt p lb;
`Gist
| _ -> (
assert false
)
)
| `Double_quote -> (
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
try
match len with
| 4 -> (
match String.unsafe_get s pos with
| 'g' -> (
if String.unsafe_get s (pos+1) = 'i' && String.unsafe_get s (pos+2) = 's' && String.unsafe_get s (pos+3) = 't' then (
5
)
else (
raise (Exit)
)
)
| 'r' -> (
if String.unsafe_get s (pos+1) = 'e' && String.unsafe_get s (pos+2) = 'p' && String.unsafe_get s (pos+3) = 'o' then (
2
)
else (
raise (Exit)
)
)
| 'u' -> (
if String.unsafe_get s (pos+1) = 's' && String.unsafe_get s (pos+2) = 'e' && String.unsafe_get s (pos+3) = 'r' then (
0
)
else (
raise (Exit)
)
)
| _ -> (
raise (Exit)
)
)
| 11 -> (
match String.unsafe_get s pos with
| 'd' -> (
if String.unsafe_get s (pos+1) = 'e' && String.unsafe_get s (pos+2) = 'l' && String.unsafe_get s (pos+3) = 'e' && String.unsafe_get s (pos+4) = 't' && String.unsafe_get s (pos+5) = 'e' && String.unsafe_get s (pos+6) = '_' && String.unsafe_get s (pos+7) = 'r' && String.unsafe_get s (pos+8) = 'e' && String.unsafe_get s (pos+9) = 'p' && String.unsafe_get s (pos+10) = 'o' then (
4
)
else (
raise (Exit)
)
)
| 'p' -> (
if String.unsafe_get s (pos+1) = 'u' && String.unsafe_get s (pos+2) = 'b' && String.unsafe_get s (pos+3) = 'l' && String.unsafe_get s (pos+4) = 'i' && String.unsafe_get s (pos+5) = 'c' && String.unsafe_get s (pos+6) = '_' && String.unsafe_get s (pos+7) = 'r' && String.unsafe_get s (pos+8) = 'e' && String.unsafe_get s (pos+9) = 'p' && String.unsafe_get s (pos+10) = 'o' then (
1
)
else (
raise (Exit)
)
)
| 'r' -> (
if String.unsafe_get s (pos+1) = 'e' && String.unsafe_get s (pos+2) = 'p' && String.unsafe_get s (pos+3) = 'o' && String.unsafe_get s (pos+4) = '_' && String.unsafe_get s (pos+5) = 's' && String.unsafe_get s (pos+6) = 't' && String.unsafe_get s (pos+7) = 'a' && String.unsafe_get s (pos+8) = 't' && String.unsafe_get s (pos+9) = 'u' && String.unsafe_get s (pos+10) = 's' then (
3
)
else (
raise (Exit)
)
)
| _ -> (
raise (Exit)
)
)
| _ -> (
raise (Exit)
)
with Exit -> (
Ag_oj_run.invalid_variant_tag (String.sub s pos len)
)
in
let i = Yojson.Safe.map_string p f lb in
match i with
| 0 ->
`User
| 1 ->
`Public_repo
| 2 ->
`Repo
| 3 ->
`Repo_status
| 4 ->
`Delete_repo
| 5 ->
`Gist
| _ -> (
assert false
)
)
| `Square_bracket -> (
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
Ag_oj_run.invalid_variant_tag (String.sub s pos len)
in
let i = Yojson.Safe.map_ident p f lb in
match i with
| _ -> (
assert false
)
)
)
let scope_of_string s =
read_scope (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
let write_app = (
fun ob x ->
Bi_outbuf.add_char ob '{';
let is_first = ref true in
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"name\":";
(
Yojson.Safe.write_string
)
ob x.app_name;
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"url\":";
(
Yojson.Safe.write_string
)
ob x.app_url;
Bi_outbuf.add_char ob '}';
)
let string_of_app ?(len = 1024) x =
let ob = Bi_outbuf.create len in
write_app ob x;
Bi_outbuf.contents ob
let read_app = (
fun p lb ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_lcurl p lb;
let x =
{
app_name = Obj.magic 0.0;
app_url = Obj.magic 0.0;
}
in
let bits0 = ref 0 in
try
Yojson.Safe.read_space p lb;
Yojson.Safe.read_object_end lb;
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
match len with
| 3 -> (
if String.unsafe_get s pos = 'u' && String.unsafe_get s (pos+1) = 'r' && String.unsafe_get s (pos+2) = 'l' then (
1
)
else (
-1
)
)
| 4 -> (
if String.unsafe_get s pos = 'n' && String.unsafe_get s (pos+1) = 'a' && String.unsafe_get s (pos+2) = 'm' && String.unsafe_get s (pos+3) = 'e' then (
0
)
else (
-1
)
)
| _ -> (
-1
)
in
let i = Yojson.Safe.map_ident p f lb in
Ag_oj_run.read_until_field_value p lb;
(
match i with
| 0 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 0 (Obj.repr v);
bits0 := !bits0 lor 0x1;
| 1 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 1 (Obj.repr v);
bits0 := !bits0 lor 0x2;
| _ -> (
Yojson.Safe.skip_json p lb
)
);
while true do
Yojson.Safe.read_space p lb;
Yojson.Safe.read_object_sep p lb;
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
match len with
| 3 -> (
if String.unsafe_get s pos = 'u' && String.unsafe_get s (pos+1) = 'r' && String.unsafe_get s (pos+2) = 'l' then (
1
)
else (
-1
)
)
| 4 -> (
if String.unsafe_get s pos = 'n' && String.unsafe_get s (pos+1) = 'a' && String.unsafe_get s (pos+2) = 'm' && String.unsafe_get s (pos+3) = 'e' then (
0
)
else (
-1
)
)
| _ -> (
-1
)
in
let i = Yojson.Safe.map_ident p f lb in
Ag_oj_run.read_until_field_value p lb;
(
match i with
| 0 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 0 (Obj.repr v);
bits0 := !bits0 lor 0x1;
| 1 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 1 (Obj.repr v);
bits0 := !bits0 lor 0x2;
| _ -> (
Yojson.Safe.skip_json p lb
)
);
done;
assert false;
with Yojson.End_of_object -> (
if !bits0 <> 0x3 then Ag_oj_run.missing_fields [| !bits0 |] [| "name"; "url" |];
Ag_oj_run.identity x
)
)
let app_of_string s =
read_app (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
let write__1 = (
Ag_oj_run.write_list (
write_scope
)
)
let string_of__1 ?(len = 1024) x =
let ob = Bi_outbuf.create len in
write__1 ob x;
Bi_outbuf.contents ob
let read__1 = (
Ag_oj_run.read_list (
read_scope
)
)
let _1_of_string s =
read__1 (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
let write_authorization_request = (
fun ob x ->
Bi_outbuf.add_char ob '{';
let is_first = ref true in
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"scopes\":";
(
write__1
)
ob x.auth_req_scopes;
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"note\":";
(
Yojson.Safe.write_string
)
ob x.auth_req_note;
Bi_outbuf.add_char ob '}';
)
let string_of_authorization_request ?(len = 1024) x =
let ob = Bi_outbuf.create len in
write_authorization_request ob x;
Bi_outbuf.contents ob
let read_authorization_request = (
fun p lb ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_lcurl p lb;
let x =
{
auth_req_scopes = Obj.magic 0.0;
auth_req_note = Obj.magic 0.0;
}
in
let bits0 = ref 0 in
try
Yojson.Safe.read_space p lb;
Yojson.Safe.read_object_end lb;
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
match len with
| 4 -> (
if String.unsafe_get s pos = 'n' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 't' && String.unsafe_get s (pos+3) = 'e' then (
1
)
else (
-1
)
)
| 6 -> (
if String.unsafe_get s pos = 's' && String.unsafe_get s (pos+1) = 'c' && String.unsafe_get s (pos+2) = 'o' && String.unsafe_get s (pos+3) = 'p' && String.unsafe_get s (pos+4) = 'e' && String.unsafe_get s (pos+5) = 's' then (
0
)
else (
-1
)
)
| _ -> (
-1
)
in
let i = Yojson.Safe.map_ident p f lb in
Ag_oj_run.read_until_field_value p lb;
(
match i with
| 0 ->
let v =
(
read__1
) p lb
in
Obj.set_field (Obj.repr x) 0 (Obj.repr v);
bits0 := !bits0 lor 0x1;
| 1 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 1 (Obj.repr v);
bits0 := !bits0 lor 0x2;
| _ -> (
Yojson.Safe.skip_json p lb
)
);
while true do
Yojson.Safe.read_space p lb;
Yojson.Safe.read_object_sep p lb;
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
match len with
| 4 -> (
if String.unsafe_get s pos = 'n' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 't' && String.unsafe_get s (pos+3) = 'e' then (
1
)
else (
-1
)
)
| 6 -> (
if String.unsafe_get s pos = 's' && String.unsafe_get s (pos+1) = 'c' && String.unsafe_get s (pos+2) = 'o' && String.unsafe_get s (pos+3) = 'p' && String.unsafe_get s (pos+4) = 'e' && String.unsafe_get s (pos+5) = 's' then (
0
)
else (
-1
)
)
| _ -> (
-1
)
in
let i = Yojson.Safe.map_ident p f lb in
Ag_oj_run.read_until_field_value p lb;
(
match i with
| 0 ->
let v =
(
read__1
) p lb
in
Obj.set_field (Obj.repr x) 0 (Obj.repr v);
bits0 := !bits0 lor 0x1;
| 1 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 1 (Obj.repr v);
bits0 := !bits0 lor 0x2;
| _ -> (
Yojson.Safe.skip_json p lb
)
);
done;
assert false;
with Yojson.End_of_object -> (
if !bits0 <> 0x3 then Ag_oj_run.missing_fields [| !bits0 |] [| "scopes"; "note" |];
Ag_oj_run.identity x
)
)
let authorization_request_of_string s =
read_authorization_request (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
let write__2 = (
Ag_oj_run.write_option (
Yojson.Safe.write_string
)
)
let string_of__2 ?(len = 1024) x =
let ob = Bi_outbuf.create len in
write__2 ob x;
Bi_outbuf.contents ob
let read__2 = (
fun p lb ->
Yojson.Safe.read_space p lb;
match Yojson.Safe.start_any_variant p lb with
| `Edgy_bracket -> (
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
try
if len = 4 then (
match String.unsafe_get s pos with
| 'N' -> (
if String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'n' && String.unsafe_get s (pos+3) = 'e' then (
0
)
else (
raise (Exit)
)
)
| 'S' -> (
if String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'm' && String.unsafe_get s (pos+3) = 'e' then (
1
)
else (
raise (Exit)
)
)
| _ -> (
raise (Exit)
)
)
else (
raise (Exit)
)
with Exit -> (
Ag_oj_run.invalid_variant_tag (String.sub s pos len)
)
in
let i = Yojson.Safe.map_ident p f lb in
match i with
| 0 ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_gt p lb;
None
| 1 ->
Ag_oj_run.read_until_field_value p lb;
let x = (
Ag_oj_run.read_string
) p lb
in
Yojson.Safe.read_space p lb;
Yojson.Safe.read_gt p lb;
Some x
| _ -> (
assert false
)
)
| `Double_quote -> (
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
try
if len = 4 && String.unsafe_get s pos = 'N' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'n' && String.unsafe_get s (pos+3) = 'e' then (
0
)
else (
raise (Exit)
)
with Exit -> (
Ag_oj_run.invalid_variant_tag (String.sub s pos len)
)
in
let i = Yojson.Safe.map_string p f lb in
match i with
| 0 ->
None
| _ -> (
assert false
)
)
| `Square_bracket -> (
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
try
if len = 4 && String.unsafe_get s pos = 'S' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'm' && String.unsafe_get s (pos+3) = 'e' then (
0
)
else (
raise (Exit)
)
with Exit -> (
Ag_oj_run.invalid_variant_tag (String.sub s pos len)
)
in
let i = Yojson.Safe.map_ident p f lb in
match i with
| 0 ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_comma p lb;
Yojson.Safe.read_space p lb;
let x = (
Ag_oj_run.read_string
) p lb
in
Yojson.Safe.read_space p lb;
Yojson.Safe.read_rbr p lb;
Some x
| _ -> (
assert false
)
)
)
let _2_of_string s =
read__2 (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
let write_authorization_response = (
fun ob x ->
Bi_outbuf.add_char ob '{';
let is_first = ref true in
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"scopes\":";
(
write__1
)
ob x.scopes;
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"token\":";
(
Yojson.Safe.write_string
)
ob x.token;
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"app\":";
(
write_app
)
ob x.app;
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"url\":";
(
Yojson.Safe.write_string
)
ob x.url;
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"id\":";
(
Yojson.Safe.write_int
)
ob x.id;
(match x.note with None -> () | Some x ->
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"note\":";
(
Yojson.Safe.write_string
)
ob x;
);
(match x.note_url with None -> () | Some x ->
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"note_url\":";
(
Yojson.Safe.write_string
)
ob x;
);
Bi_outbuf.add_char ob '}';
)
let string_of_authorization_response ?(len = 1024) x =
let ob = Bi_outbuf.create len in
write_authorization_response ob x;
Bi_outbuf.contents ob
let read_authorization_response = (
fun p lb ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_lcurl p lb;
let x =
{
scopes = Obj.magic 0.0;
token = Obj.magic 0.0;
app = Obj.magic 0.0;
url = Obj.magic 0.0;
id = Obj.magic 0.0;
note = None;
note_url = None;
}
in
let bits0 = ref 0 in
try
Yojson.Safe.read_space p lb;
Yojson.Safe.read_object_end lb;
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
match len with
| 2 -> (
if String.unsafe_get s pos = 'i' && String.unsafe_get s (pos+1) = 'd' then (
4
)
else (
-1
)
)
| 3 -> (
match String.unsafe_get s pos with
| 'a' -> (
if String.unsafe_get s (pos+1) = 'p' && String.unsafe_get s (pos+2) = 'p' then (
2
)
else (
-1
)
)
| 'u' -> (
if String.unsafe_get s (pos+1) = 'r' && String.unsafe_get s (pos+2) = 'l' then (
3
)
else (
-1
)
)
| _ -> (
-1
)
)
| 4 -> (
if String.unsafe_get s pos = 'n' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 't' && String.unsafe_get s (pos+3) = 'e' then (
5
)
else (
-1
)
)
| 5 -> (
if String.unsafe_get s pos = 't' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'k' && String.unsafe_get s (pos+3) = 'e' && String.unsafe_get s (pos+4) = 'n' then (
1
)
else (
-1
)
)
| 6 -> (
if String.unsafe_get s pos = 's' && String.unsafe_get s (pos+1) = 'c' && String.unsafe_get s (pos+2) = 'o' && String.unsafe_get s (pos+3) = 'p' && String.unsafe_get s (pos+4) = 'e' && String.unsafe_get s (pos+5) = 's' then (
0
)
else (
-1
)
)
| 8 -> (
if String.unsafe_get s pos = 'n' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 't' && String.unsafe_get s (pos+3) = 'e' && String.unsafe_get s (pos+4) = '_' && String.unsafe_get s (pos+5) = 'u' && String.unsafe_get s (pos+6) = 'r' && String.unsafe_get s (pos+7) = 'l' then (
6
)
else (
-1
)
)
| _ -> (
-1
)
in
let i = Yojson.Safe.map_ident p f lb in
Ag_oj_run.read_until_field_value p lb;
(
match i with
| 0 ->
let v =
(
read__1
) p lb
in
Obj.set_field (Obj.repr x) 0 (Obj.repr v);
bits0 := !bits0 lor 0x1;
| 1 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 1 (Obj.repr v);
bits0 := !bits0 lor 0x2;
| 2 ->
let v =
(
read_app
) p lb
in
Obj.set_field (Obj.repr x) 2 (Obj.repr v);
bits0 := !bits0 lor 0x4;
| 3 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 3 (Obj.repr v);
bits0 := !bits0 lor 0x8;
| 4 ->
let v =
(
Ag_oj_run.read_int
) p lb
in
Obj.set_field (Obj.repr x) 4 (Obj.repr v);
bits0 := !bits0 lor 0x10;
| 5 ->
if not (Yojson.Safe.read_null_if_possible p lb) then (
let v =
Some (
(
Ag_oj_run.read_string
) p lb
)
in
Obj.set_field (Obj.repr x) 5 (Obj.repr v);
)
| 6 ->
if not (Yojson.Safe.read_null_if_possible p lb) then (
let v =
Some (
(
Ag_oj_run.read_string
) p lb
)
in
Obj.set_field (Obj.repr x) 6 (Obj.repr v);
)
| _ -> (
Yojson.Safe.skip_json p lb
)
);
while true do
Yojson.Safe.read_space p lb;
Yojson.Safe.read_object_sep p lb;
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
match len with
| 2 -> (
if String.unsafe_get s pos = 'i' && String.unsafe_get s (pos+1) = 'd' then (
4
)
else (
-1
)
)
| 3 -> (
match String.unsafe_get s pos with
| 'a' -> (
if String.unsafe_get s (pos+1) = 'p' && String.unsafe_get s (pos+2) = 'p' then (
2
)
else (
-1
)
)
| 'u' -> (
if String.unsafe_get s (pos+1) = 'r' && String.unsafe_get s (pos+2) = 'l' then (
3
)
else (
-1
)
)
| _ -> (
-1
)
)
| 4 -> (
if String.unsafe_get s pos = 'n' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 't' && String.unsafe_get s (pos+3) = 'e' then (
5
)
else (
-1
)
)
| 5 -> (
if String.unsafe_get s pos = 't' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'k' && String.unsafe_get s (pos+3) = 'e' && String.unsafe_get s (pos+4) = 'n' then (
1
)
else (
-1
)
)
| 6 -> (
if String.unsafe_get s pos = 's' && String.unsafe_get s (pos+1) = 'c' && String.unsafe_get s (pos+2) = 'o' && String.unsafe_get s (pos+3) = 'p' && String.unsafe_get s (pos+4) = 'e' && String.unsafe_get s (pos+5) = 's' then (
0
)
else (
-1
)
)
| 8 -> (
if String.unsafe_get s pos = 'n' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 't' && String.unsafe_get s (pos+3) = 'e' && String.unsafe_get s (pos+4) = '_' && String.unsafe_get s (pos+5) = 'u' && String.unsafe_get s (pos+6) = 'r' && String.unsafe_get s (pos+7) = 'l' then (
6
)
else (
-1
)
)
| _ -> (
-1
)
in
let i = Yojson.Safe.map_ident p f lb in
Ag_oj_run.read_until_field_value p lb;
(
match i with
| 0 ->
let v =
(
read__1
) p lb
in
Obj.set_field (Obj.repr x) 0 (Obj.repr v);
bits0 := !bits0 lor 0x1;
| 1 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 1 (Obj.repr v);
bits0 := !bits0 lor 0x2;
| 2 ->
let v =
(
read_app
) p lb
in
Obj.set_field (Obj.repr x) 2 (Obj.repr v);
bits0 := !bits0 lor 0x4;
| 3 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 3 (Obj.repr v);
bits0 := !bits0 lor 0x8;
| 4 ->
let v =
(
Ag_oj_run.read_int
) p lb
in
Obj.set_field (Obj.repr x) 4 (Obj.repr v);
bits0 := !bits0 lor 0x10;
| 5 ->
if not (Yojson.Safe.read_null_if_possible p lb) then (
let v =
Some (
(
Ag_oj_run.read_string
) p lb
)
in
Obj.set_field (Obj.repr x) 5 (Obj.repr v);
)
| 6 ->
if not (Yojson.Safe.read_null_if_possible p lb) then (
let v =
Some (
(
Ag_oj_run.read_string
) p lb
)
in
Obj.set_field (Obj.repr x) 6 (Obj.repr v);
)
| _ -> (
Yojson.Safe.skip_json p lb
)
);
done;
assert false;
with Yojson.End_of_object -> (
if !bits0 <> 0x1f then Ag_oj_run.missing_fields [| !bits0 |] [| "scopes"; "token"; "app"; "url"; "id" |];
Ag_oj_run.identity x
)
)
let authorization_response_of_string s =
read_authorization_response (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
================================================
FILE: code/json/github_j.mli
================================================
(* Auto-generated from "github.atd" *)
type scope = Github_t.scope
type app = Github_t.app = {
app_name (*atd name *): string;
app_url (*atd url *): string
}
type authorization_request = Github_t.authorization_request = {
auth_req_scopes (*atd scopes *): scope list;
auth_req_note (*atd note *): string
}
type authorization_response = Github_t.authorization_response = {
scopes: scope list;
token: string;
app: app;
url: string;
id: int;
note: string option;
note_url: string option
}
val write_scope :
Bi_outbuf.t -> scope -> unit
(** Output a JSON value of type {!scope}. *)
val string_of_scope :
?len:int -> scope -> string
(** Serialize a value of type {!scope}
into a JSON string.
@param len specifies the initial length
of the buffer used internally.
Default: 1024. *)
val read_scope :
Yojson.Safe.lexer_state -> Lexing.lexbuf -> scope
(** Input JSON data of type {!scope}. *)
val scope_of_string :
string -> scope
(** Deserialize JSON data of type {!scope}. *)
val write_app :
Bi_outbuf.t -> app -> unit
(** Output a JSON value of type {!app}. *)
val string_of_app :
?len:int -> app -> string
(** Serialize a value of type {!app}
into a JSON string.
@param len specifies the initial length
of the buffer used internally.
Default: 1024. *)
val read_app :
Yojson.Safe.lexer_state -> Lexing.lexbuf -> app
(** Input JSON data of type {!app}. *)
val app_of_string :
string -> app
(** Deserialize JSON data of type {!app}. *)
val write_authorization_request :
Bi_outbuf.t -> authorization_request -> unit
(** Output a JSON value of type {!authorization_request}. *)
val string_of_authorization_request :
?len:int -> authorization_request -> string
(** Serialize a value of type {!authorization_request}
into a JSON string.
@param len specifies the initial length
of the buffer used internally.
Default: 1024. *)
val read_authorization_request :
Yojson.Safe.lexer_state -> Lexing.lexbuf -> authorization_request
(** Input JSON data of type {!authorization_request}. *)
val authorization_request_of_string :
string -> authorization_request
(** Deserialize JSON data of type {!authorization_request}. *)
val write_authorization_response :
Bi_outbuf.t -> authorization_response -> unit
(** Output a JSON value of type {!authorization_response}. *)
val string_of_authorization_response :
?len:int -> authorization_response -> string
(** Serialize a value of type {!authorization_response}
into a JSON string.
@param len specifies the initial length
of the buffer used internally.
Default: 1024. *)
val read_authorization_response :
Yojson.Safe.lexer_state -> Lexing.lexbuf -> authorization_response
(** Input JSON data of type {!authorization_response}. *)
val authorization_response_of_string :
string -> authorization_response
(** Deserialize JSON data of type {!authorization_response}. *)
================================================
FILE: code/json/github_j_excerpt.mli
================================================
val string_of_authorization_request :
?len:int -> authorization_request -> string
(** Serialize a value of type {!authorization_request}
into a JSON string.
@param len specifies the initial length
of the buffer used internally.
Default: 1024. *)
val string_of_authorization_response :
?len:int -> authorization_response -> string
(** Serialize a value of type {!authorization_response}
into a JSON string.
@param len specifies the initial length
of the buffer used internally.
Default: 1024. *)
================================================
FILE: code/json/github_org.atd
================================================
type org = {
login: string;
id: int;
url: string;
?name: string option;
?blog: string option;
?email: string option;
public_repos: int
}
================================================
FILE: code/json/github_org_info.ml
================================================
open Core.Std
let print_org file () =
let url = sprintf "https://api.github.com/orgs/%s" file in
Core_extended.Shell.run_full "curl" [url]
|> Github_org_j.org_of_string
|> fun org ->
let open Github_org_t in
let name = Option.value ~default:"???" org.name in
printf "%s (%d) with %d public repos\n"
name org.id org.public_repos
let () =
Command.basic ~summary:"Print Github organization information"
Command.Spec.(empty +> anon ("organization" %: string))
print_org
|> Command.run
================================================
FILE: code/json/github_org_j.ml
================================================
(* Auto-generated from "github_org.atd" *)
type org = Github_org_t.org = {
login: string;
id: int;
url: string;
name: string option;
blog: string option;
email: string option;
public_repos: int
}
let write__1 = (
Ag_oj_run.write_option (
Yojson.Safe.write_string
)
)
let string_of__1 ?(len = 1024) x =
let ob = Bi_outbuf.create len in
write__1 ob x;
Bi_outbuf.contents ob
let read__1 = (
fun p lb ->
Yojson.Safe.read_space p lb;
match Yojson.Safe.start_any_variant p lb with
| `Edgy_bracket -> (
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
try
if len = 4 then (
match String.unsafe_get s pos with
| 'N' -> (
if String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'n' && String.unsafe_get s (pos+3) = 'e' then (
0
)
else (
raise (Exit)
)
)
| 'S' -> (
if String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'm' && String.unsafe_get s (pos+3) = 'e' then (
1
)
else (
raise (Exit)
)
)
| _ -> (
raise (Exit)
)
)
else (
raise (Exit)
)
with Exit -> (
Ag_oj_run.invalid_variant_tag (String.sub s pos len)
)
in
let i = Yojson.Safe.map_ident p f lb in
match i with
| 0 ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_gt p lb;
None
| 1 ->
Ag_oj_run.read_until_field_value p lb;
let x = (
Ag_oj_run.read_string
) p lb
in
Yojson.Safe.read_space p lb;
Yojson.Safe.read_gt p lb;
Some x
| _ -> (
assert false
)
)
| `Double_quote -> (
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
try
if len = 4 && String.unsafe_get s pos = 'N' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'n' && String.unsafe_get s (pos+3) = 'e' then (
0
)
else (
raise (Exit)
)
with Exit -> (
Ag_oj_run.invalid_variant_tag (String.sub s pos len)
)
in
let i = Yojson.Safe.map_string p f lb in
match i with
| 0 ->
None
| _ -> (
assert false
)
)
| `Square_bracket -> (
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
try
if len = 4 && String.unsafe_get s pos = 'S' && String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'm' && String.unsafe_get s (pos+3) = 'e' then (
0
)
else (
raise (Exit)
)
with Exit -> (
Ag_oj_run.invalid_variant_tag (String.sub s pos len)
)
in
let i = Yojson.Safe.map_ident p f lb in
match i with
| 0 ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_comma p lb;
Yojson.Safe.read_space p lb;
let x = (
Ag_oj_run.read_string
) p lb
in
Yojson.Safe.read_space p lb;
Yojson.Safe.read_rbr p lb;
Some x
| _ -> (
assert false
)
)
)
let _1_of_string s =
read__1 (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
let write_org = (
fun ob x ->
Bi_outbuf.add_char ob '{';
let is_first = ref true in
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"login\":";
(
Yojson.Safe.write_string
)
ob x.login;
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"id\":";
(
Yojson.Safe.write_int
)
ob x.id;
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"url\":";
(
Yojson.Safe.write_string
)
ob x.url;
(match x.name with None -> () | Some x ->
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"name\":";
(
Yojson.Safe.write_string
)
ob x;
);
(match x.blog with None -> () | Some x ->
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"blog\":";
(
Yojson.Safe.write_string
)
ob x;
);
(match x.email with None -> () | Some x ->
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"email\":";
(
Yojson.Safe.write_string
)
ob x;
);
if !is_first then
is_first := false
else
Bi_outbuf.add_char ob ',';
Bi_outbuf.add_string ob "\"public_repos\":";
(
Yojson.Safe.write_int
)
ob x.public_repos;
Bi_outbuf.add_char ob '}';
)
let string_of_org ?(len = 1024) x =
let ob = Bi_outbuf.create len in
write_org ob x;
Bi_outbuf.contents ob
let read_org = (
fun p lb ->
Yojson.Safe.read_space p lb;
Yojson.Safe.read_lcurl p lb;
let x =
{
login = Obj.magic 0.0;
id = Obj.magic 0.0;
url = Obj.magic 0.0;
name = None;
blog = None;
email = None;
public_repos = Obj.magic 0.0;
}
in
let bits0 = ref 0 in
try
Yojson.Safe.read_space p lb;
Yojson.Safe.read_object_end lb;
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
match len with
| 2 -> (
if String.unsafe_get s pos = 'i' && String.unsafe_get s (pos+1) = 'd' then (
1
)
else (
-1
)
)
| 3 -> (
if String.unsafe_get s pos = 'u' && String.unsafe_get s (pos+1) = 'r' && String.unsafe_get s (pos+2) = 'l' then (
2
)
else (
-1
)
)
| 4 -> (
match String.unsafe_get s pos with
| 'b' -> (
if String.unsafe_get s (pos+1) = 'l' && String.unsafe_get s (pos+2) = 'o' && String.unsafe_get s (pos+3) = 'g' then (
4
)
else (
-1
)
)
| 'n' -> (
if String.unsafe_get s (pos+1) = 'a' && String.unsafe_get s (pos+2) = 'm' && String.unsafe_get s (pos+3) = 'e' then (
3
)
else (
-1
)
)
| _ -> (
-1
)
)
| 5 -> (
match String.unsafe_get s pos with
| 'e' -> (
if String.unsafe_get s (pos+1) = 'm' && String.unsafe_get s (pos+2) = 'a' && String.unsafe_get s (pos+3) = 'i' && String.unsafe_get s (pos+4) = 'l' then (
5
)
else (
-1
)
)
| 'l' -> (
if String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'g' && String.unsafe_get s (pos+3) = 'i' && String.unsafe_get s (pos+4) = 'n' then (
0
)
else (
-1
)
)
| _ -> (
-1
)
)
| 12 -> (
if String.unsafe_get s pos = 'p' && String.unsafe_get s (pos+1) = 'u' && String.unsafe_get s (pos+2) = 'b' && String.unsafe_get s (pos+3) = 'l' && String.unsafe_get s (pos+4) = 'i' && String.unsafe_get s (pos+5) = 'c' && String.unsafe_get s (pos+6) = '_' && String.unsafe_get s (pos+7) = 'r' && String.unsafe_get s (pos+8) = 'e' && String.unsafe_get s (pos+9) = 'p' && String.unsafe_get s (pos+10) = 'o' && String.unsafe_get s (pos+11) = 's' then (
6
)
else (
-1
)
)
| _ -> (
-1
)
in
let i = Yojson.Safe.map_ident p f lb in
Ag_oj_run.read_until_field_value p lb;
(
match i with
| 0 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 0 (Obj.repr v);
bits0 := !bits0 lor 0x1;
| 1 ->
let v =
(
Ag_oj_run.read_int
) p lb
in
Obj.set_field (Obj.repr x) 1 (Obj.repr v);
bits0 := !bits0 lor 0x2;
| 2 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 2 (Obj.repr v);
bits0 := !bits0 lor 0x4;
| 3 ->
if not (Yojson.Safe.read_null_if_possible p lb) then (
let v =
Some (
(
Ag_oj_run.read_string
) p lb
)
in
Obj.set_field (Obj.repr x) 3 (Obj.repr v);
)
| 4 ->
if not (Yojson.Safe.read_null_if_possible p lb) then (
let v =
Some (
(
Ag_oj_run.read_string
) p lb
)
in
Obj.set_field (Obj.repr x) 4 (Obj.repr v);
)
| 5 ->
if not (Yojson.Safe.read_null_if_possible p lb) then (
let v =
Some (
(
Ag_oj_run.read_string
) p lb
)
in
Obj.set_field (Obj.repr x) 5 (Obj.repr v);
)
| 6 ->
let v =
(
Ag_oj_run.read_int
) p lb
in
Obj.set_field (Obj.repr x) 6 (Obj.repr v);
bits0 := !bits0 lor 0x8;
| _ -> (
Yojson.Safe.skip_json p lb
)
);
while true do
Yojson.Safe.read_space p lb;
Yojson.Safe.read_object_sep p lb;
Yojson.Safe.read_space p lb;
let f =
fun s pos len ->
if pos < 0 || len < 0 || pos + len > String.length s then
invalid_arg "out-of-bounds substring position or length";
match len with
| 2 -> (
if String.unsafe_get s pos = 'i' && String.unsafe_get s (pos+1) = 'd' then (
1
)
else (
-1
)
)
| 3 -> (
if String.unsafe_get s pos = 'u' && String.unsafe_get s (pos+1) = 'r' && String.unsafe_get s (pos+2) = 'l' then (
2
)
else (
-1
)
)
| 4 -> (
match String.unsafe_get s pos with
| 'b' -> (
if String.unsafe_get s (pos+1) = 'l' && String.unsafe_get s (pos+2) = 'o' && String.unsafe_get s (pos+3) = 'g' then (
4
)
else (
-1
)
)
| 'n' -> (
if String.unsafe_get s (pos+1) = 'a' && String.unsafe_get s (pos+2) = 'm' && String.unsafe_get s (pos+3) = 'e' then (
3
)
else (
-1
)
)
| _ -> (
-1
)
)
| 5 -> (
match String.unsafe_get s pos with
| 'e' -> (
if String.unsafe_get s (pos+1) = 'm' && String.unsafe_get s (pos+2) = 'a' && String.unsafe_get s (pos+3) = 'i' && String.unsafe_get s (pos+4) = 'l' then (
5
)
else (
-1
)
)
| 'l' -> (
if String.unsafe_get s (pos+1) = 'o' && String.unsafe_get s (pos+2) = 'g' && String.unsafe_get s (pos+3) = 'i' && String.unsafe_get s (pos+4) = 'n' then (
0
)
else (
-1
)
)
| _ -> (
-1
)
)
| 12 -> (
if String.unsafe_get s pos = 'p' && String.unsafe_get s (pos+1) = 'u' && String.unsafe_get s (pos+2) = 'b' && String.unsafe_get s (pos+3) = 'l' && String.unsafe_get s (pos+4) = 'i' && String.unsafe_get s (pos+5) = 'c' && String.unsafe_get s (pos+6) = '_' && String.unsafe_get s (pos+7) = 'r' && String.unsafe_get s (pos+8) = 'e' && String.unsafe_get s (pos+9) = 'p' && String.unsafe_get s (pos+10) = 'o' && String.unsafe_get s (pos+11) = 's' then (
6
)
else (
-1
)
)
| _ -> (
-1
)
in
let i = Yojson.Safe.map_ident p f lb in
Ag_oj_run.read_until_field_value p lb;
(
match i with
| 0 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 0 (Obj.repr v);
bits0 := !bits0 lor 0x1;
| 1 ->
let v =
(
Ag_oj_run.read_int
) p lb
in
Obj.set_field (Obj.repr x) 1 (Obj.repr v);
bits0 := !bits0 lor 0x2;
| 2 ->
let v =
(
Ag_oj_run.read_string
) p lb
in
Obj.set_field (Obj.repr x) 2 (Obj.repr v);
bits0 := !bits0 lor 0x4;
| 3 ->
if not (Yojson.Safe.read_null_if_possible p lb) then (
let v =
Some (
(
Ag_oj_run.read_string
) p lb
)
in
Obj.set_field (Obj.repr x) 3 (Obj.repr v);
)
| 4 ->
if not (Yojson.Safe.read_null_if_possible p lb) then (
let v =
Some (
(
Ag_oj_run.read_string
) p lb
)
in
Obj.set_field (Obj.repr x) 4 (Obj.repr v);
)
| 5 ->
if not (Yojson.Safe.read_null_if_possible p lb) then (
let v =
Some (
(
Ag_oj_run.read_string
) p lb
)
in
Obj.set_field (Obj.repr x) 5 (Obj.repr v);
)
| 6 ->
let v =
(
Ag_oj_run.read_int
) p lb
in
Obj.set_field (Obj.repr x) 6 (Obj.repr v);
bits0 := !bits0 lor 0x8;
| _ -> (
Yojson.Safe.skip_json p lb
)
);
done;
assert false;
with Yojson.End_of_object -> (
if !bits0 <> 0xf then Ag_oj_run.missing_fields [| !bits0 |] [| "login"; "id"; "url"; "public_repos" |];
Ag_oj_run.identity x
)
)
let org_of_string s =
read_org (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
================================================
FILE: code/json/github_org_j.mli
================================================
(* Auto-generated from "github_org.atd" *)
type org = Github_org_t.org = {
login: string;
id: int;
url: string;
name: string option;
blog: string option;
email: string option;
public_repos: int
}
val write_org :
Bi_outbuf.t -> org -> unit
(** Output a JSON value of type {!org}. *)
val string_of_org :
?len:int -> org -> string
(** Serialize a value of type {!org}
into a JSON string.
@param len specifies the initial length
of the buffer used internally.
Default: 1024. *)
val read_org :
Yojson.Safe.lexer_state -> Lexing.lexbuf -> org
(** Input JSON data of type {!org}. *)
val org_of_string :
string -> org
(** Deserialize JSON data of type {!org}. *)
================================================
FILE: code/json/github_org_t.ml
================================================
(* Auto-generated from "github_org.atd" *)
type org = {
login: string;
id: int;
url: string;
name: string option;
blog: string option;
email: string option;
public_repos: int
}
================================================
FILE: code/json/github_org_t.mli
================================================
(* Auto-generated from "github_org.atd" *)
type org = {
login: string;
id: int;
url: string;
name: string option;
blog: string option;
email: string option;
public_repos: int
}
================================================
FILE: code/json/github_t.ml
================================================
(* Auto-generated from "github.atd" *)
type scope = [
`User | `Public_repo | `Repo | `Repo_status | `Delete_repo | `Gist
]
type app = { app_name (*atd name *): string; app_url (*atd url *): string }
type authorization_request = {
auth_req_scopes (*atd scopes *): scope list;
auth_req_note (*atd note *): string
}
type authorization_response = {
scopes: scope list;
token: string;
app: app;
url: string;
id: int;
note: string option;
note_url: string option
}
================================================
FILE: code/json/github_t.mli
================================================
(* Auto-generated from "github.atd" *)
type scope = [
`User | `Public_repo | `Repo | `Repo_status | `Delete_repo | `Gist
]
type app = { app_name (*atd name *): string; app_url (*atd url *): string }
type authorization_request = {
auth_req_scopes (*atd scopes *): scope list;
auth_req_note (*atd note *): string
}
type authorization_response = {
scopes: scope list;
token: string;
app: app;
url: string;
id: int;
note: string option;
note_url: string option
}
================================================
FILE: code/json/install.topscript
================================================
#require "yojson" ;;
open Yojson ;;
================================================
FILE: code/json/install_atdgen.rawsh
================================================
$ opam install atdgen
$ atdgen -version
1.2.3
================================================
FILE: code/json/list_excerpt.mli
================================================
val map : 'a list -> f:('a -> 'b) -> 'b list
val fold : 'a list -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum
(* part 1 *)
val iter : 'a list -> f:('a -> unit) -> unit
================================================
FILE: code/json/parse_book.ml
================================================
open Core.Std
let () =
(* Read the JSON file *)
let json = Yojson.Basic.from_file "book.json" in
(* Locally open the JSON manipulation functions *)
let open Yojson.Basic.Util in
let title = json |> member "title" |> to_string in
let tags = json |> member "tags" |> to_list |> filter_string in
let pages = json |> member "pages" |> to_int in
let is_online = json |> member "is_online" |> to_bool_option in
let is_translated = json |> member "is_translated" |> to_bool_option in
let authors = json |> member "authors" |> to_list in
let names = List.map authors ~f:(fun json -> member "name" json |> to_string) in
(* Print the results of the parsing *)
printf "Title: %s (%d)\n" title pages;
printf "Authors: %s\n" (String.concat ~sep:", " names);
printf "Tags: %s\n" (String.concat ~sep:", " tags);
let string_of_bool_option =
function
| None -> ""
| Some true -> "yes"
| Some false -> "no" in
printf "Online: %s\n" (string_of_bool_option is_online);
printf "Translated: %s\n" (string_of_bool_option is_translated)
================================================
FILE: code/json/parse_book.topscript
================================================
#require "yojson" ;;
let json = Yojson.Basic.from_file "book.json" ;;
#part 1
open Yojson.Basic.Util ;;
let title = json |> member "title" |> to_string ;;
#part 2
let tags = json |> member "tags" |> to_list |> filter_string ;;
let pages = json |> member "pages" |> to_int ;;
#part 3
let is_online = json |> member "is_online" |> to_bool_option ;;
let is_translated = json |> member "is_translated" |> to_bool_option ;;
#part 4
let authors = json |> member "authors" |> to_list ;;
#part 5
let names =
json |> member "authors" |> to_list
|> List.map ~f:(fun json -> member "name" json |> to_string) ;;
================================================
FILE: code/json/read_json.ml
================================================
open Core.Std
let () =
(* Read JSON file into an OCaml string *)
let buf = In_channel.read_all "book.json" in
(* Use the string JSON constructor *)
let json1 = Yojson.Basic.from_string buf in
(* Use the file JSON constructor *)
let json2 = Yojson.Basic.from_file "book.json" in
(* Test that the two values are the same *)
print_endline (if json1 = json2 then "OK" else "FAIL")
================================================
FILE: code/json/run_github_org.sh
================================================
./github_org_info.native mirage
./github_org_info.native janestreet
================================================
FILE: code/json/run_parse_book.sh
================================================
corebuild -pkg yojson parse_book.native
./parse_book.native
================================================
FILE: code/json/run_read_json.sh
================================================
corebuild -pkg yojson read_json.native
./read_json.native
================================================
FILE: code/json/yojson_basic.mli
================================================
type json = [
| `Assoc of (string * json) list
| `Bool of bool
| `Float of float
| `Int of int
| `List of json list
| `Null
| `String of string
]
(* part 1 *)
val from_string : ?buf:Bi_outbuf.t -> ?fname:string -> ?lnum:int ->
string -> json
(* Read a JSON value from a string.
[buf] : use this buffer at will during parsing instead of
creating a new one.
[fname] : data file name to be used in error messages. It does not
have to be a real file.
[lnum] : number of the first line of input. Default is 1. *)
val from_file : ?buf:Bi_outbuf.t -> ?fname:string -> ?lnum:int ->
string -> json
(* Read a JSON value from a file. See [from_string] for the meaning of the optional
arguments. *)
val from_channel : ?buf:Bi_outbuf.t -> ?fname:string -> ?lnum:int ->
in_channel -> json
(** Read a JSON value from a channel.
See [from_string] for the meaning of the optional arguments. *)
================================================
FILE: code/json/yojson_basic_simple.mli
================================================
val from_string : string -> json
val from_file : string -> json
val from_channel : in_channel -> json
================================================
FILE: code/json/yojson_safe.mli
================================================
type json = [
| `Assoc of (string * json) list
| `Bool of bool
| `Float of float
| `Floatlit of string
| `Int of int
| `Intlit of string
| `List of json list
| `Null
| `String of string
| `Stringlit of string
| `Tuple of json list
| `Variant of string * json option
]
(* part 1 *)
val to_basic : json -> Yojson.Basic.json
(** Tuples are converted to JSON arrays, Variants are converted to
JSON strings or arrays of a string (constructor) and a json value
(argument). Long integers are converted to JSON strings.
Examples:
`Tuple [ `Int 1; `Float 2.3 ] -> `List [ `Int 1; `Float 2.3 ]
`Variant ("A", None) -> `String "A"
`Variant ("B", Some x) -> `List [ `String "B", x ]
`Intlit "12345678901234567890" -> `String "12345678901234567890"
*)
================================================
FILE: code/lists-and-patterns/example.ml
================================================
================================================
FILE: code/lists-and-patterns/example.mli
================================================
================================================
FILE: code/lists-and-patterns/lists_layout.ascii
================================================
+---+---+ +---+---+ +---+---+
| 1 | *---->| 2 | *---->| 3 | *---->||
+---+---+ +---+---+ +---+---+
================================================
FILE: code/lists-and-patterns/main.topscript
================================================
[1;2;3];;
#part 1
1 :: (2 :: (3 :: [])) ;;
1 :: 2 :: 3 :: [] ;;
#part 2
let empty = [];;
3 :: empty;;
"three" :: empty;;
#part 3
let l = 1 :: 2 :: 3 :: [];;
let m = 0 :: l;;
l;;
#part 4
let rec sum l =
match l with
| [] -> 0
| hd :: tl -> hd + sum tl
;;
sum [1;2;3];;
sum [];;
#part 5
let rec drop_value l to_drop =
match l with
| [] -> []
| to_drop :: tl -> drop_value tl to_drop
| hd :: tl -> hd :: drop_value tl to_drop
;;
#part 6
drop_value [1;2;3] 2;;
#part 7
let rec drop_value l to_drop =
match l with
| [] -> []
| hd :: tl ->
let new_tl = drop_value tl to_drop in
if hd = to_drop then new_tl else hd :: new_tl
;;
drop_value [1;2;3] 2;;
#part 8
let rec drop_zero l =
match l with
| [] -> []
| 0 :: tl -> drop_zero tl
| hd :: tl -> hd :: drop_zero tl
;;
drop_zero [1;2;0;3];;
#part 9
let plus_one_match x =
match x with
| 0 -> 1
| 1 -> 2
| 2 -> 3
| _ -> x + 1
let plus_one_if x =
if x = 0 then 1
else if x = 1 then 2
else if x = 2 then 3
else x + 1
;;
#part 10
#require "core_bench";;
open Core_bench.Std;;
let run_bench tests =
Bench.bench
~ascii_table:true
~display:Textutils.Ascii_table.Display.column_titles
tests
;;
[ Bench.Test.create ~name:"plus_one_match" (fun () ->
ignore (plus_one_match 10))
; Bench.Test.create ~name:"plus_one_if" (fun () ->
ignore (plus_one_if 10)) ]
|> run_bench
;;
#part 11
let rec sum_if l =
if List.is_empty l then 0
else List.hd_exn l + sum_if (List.tl_exn l)
;;
#part 12
let numbers = List.range 0 1000 in
[ Bench.Test.create ~name:"sum_if" (fun () -> ignore (sum_if numbers))
; Bench.Test.create ~name:"sum" (fun () -> ignore (sum numbers)) ]
|> run_bench
;;
#part 13
let rec drop_zero l =
match l with
| [] -> []
| 0 :: tl -> drop_zero tl
;;
#part 14
List.map ~f:String.length ["Hello"; "World!"];;
#part 15
List.map2_exn ~f:Int.max [1;2;3] [3;2;1];;
#part 16
List.map2_exn ~f:Int.max [1;2;3] [3;2;1;0];;
#part 17
List.fold;;
#part 18
List.fold ~init:0 ~f:(+) [1;2;3;4];;
#part 19
List.fold ~init:[] ~f:(fun list x -> x :: list) [1;2;3;4];;
#part 20
let max_widths header rows =
let lengths l = List.map ~f:String.length l in
List.fold rows
~init:(lengths header)
~f:(fun acc row ->
List.map2_exn ~f:Int.max acc (lengths row))
;;
#part 21
let render_separator widths =
let pieces = List.map widths
~f:(fun w -> String.make (w + 2) '-')
in
"|" ^ String.concat ~sep:"+" pieces ^ "|"
;;
render_separator [3;6;2];;
#part 22
let s = "." ^ "." ^ "." ^ "." ^ "." ^ "." ^ ".";;
#part 23
let s = String.concat [".";".";".";".";".";".";"."];;
#part 24
let pad s length =
" " ^ s ^ String.make (length - String.length s + 1) ' '
;;
pad "hello" 10;;
#part 25
let render_row row widths =
let padded = List.map2_exn row widths ~f:pad in
"|" ^ String.concat ~sep:"|" padded ^ "|"
;;
render_row ["Hello";"World"] [10;15];;
#part 26
let render_table header rows =
let widths = max_widths header rows in
String.concat ~sep:"\n"
(render_row header widths
:: render_separator widths
:: List.map rows ~f:(fun row -> render_row row widths)
)
;;
#part 27
List.reduce;;
#part 28
List.reduce ~f:(+) [1;2;3;4;5];;
List.reduce ~f:(+) [];;
#part 29
List.filter ~f:(fun x -> x mod 2 = 0) [1;2;3;4;5];;
#part 30
List.filter_map (Sys.ls_dir ".") ~f:(fun fname ->
match String.rsplit2 ~on:'.' fname with
| None | Some ("",_) -> None
| Some (_,ext) ->
Some ext)
|> List.dedup
;;
#part 31
let is_ocaml_source s =
match String.rsplit2 s ~on:'.' with
| Some (_,("ml"|"mli")) -> true
| _ -> false
;;
let (ml_files,other_files) =
List.partition_tf (Sys.ls_dir ".") ~f:is_ocaml_source;;
#part 32
List.append [1;2;3] [4;5;6];;
#part 33
[1;2;3] @ [4;5;6];;
#part 34
List.concat [[1;2];[3;4;5];[6];[]];;
#part 35
let rec ls_rec s =
if Sys.is_file_exn ~follow_symlinks:true s
then [s]
else
Sys.ls_dir s
|> List.map ~f:(fun sub -> ls_rec (s ^/ sub))
|> List.concat
;;
#part 36
let rec ls_rec s =
if Sys.is_file_exn ~follow_symlinks:true s
then [s]
else
Sys.ls_dir s
|> List.concat_map ~f:(fun sub -> ls_rec (s ^/ sub))
;;
#part 37
let rec length = function
| [] -> 0
| _ :: tl -> 1 + length tl
;;
length [1;2;3];;
#part 38
let make_list n = List.init n ~f:(fun x -> x);;
length (make_list 10);;
length (make_list 10_000_000);;
#part 39
let rec length_plus_n l n =
match l with
| [] -> n
| _ :: tl -> length_plus_n tl (n + 1)
;;
let length l = length_plus_n l 0 ;;
length [1;2;3;4];;
#part 40
length (make_list 10_000_000);;
#part 41
let rec destutter list =
match list with
| [] -> []
| [hd] -> [hd]
| hd :: hd' :: tl ->
if hd = hd' then destutter (hd' :: tl)
else hd :: destutter (hd' :: tl)
;;
#part 42
let rec destutter = function
| [] as l -> l
| [_] as l -> l
| hd :: (hd' :: _ as tl) ->
if hd = hd' then destutter tl
else hd :: destutter tl
;;
#part 43
let rec destutter = function
| [] | [_] as l -> l
| hd :: (hd' :: _ as tl) ->
if hd = hd' then destutter tl
else hd :: destutter tl
;;
#part 44
let rec destutter = function
| [] | [_] as l -> l
| hd :: (hd' :: _ as tl) when hd = hd' -> destutter tl
| hd :: tl -> hd :: destutter tl
;;
#part 45
3 = 4;;
[3;4;5] = [3;4;5];;
[Some 3; None] = [None; Some 3];;
#part 46
(=);;
#part 47
(fun x -> x + 1) = (fun x -> x + 1);;
#part 48
let rec count_some list =
match list with
| [] -> 0
| x :: tl when Option.is_none x -> count_some tl
| x :: tl when Option.is_some x -> 1 + count_some tl
;;
#part 49
count_some [Some 3; None; Some 4];;
#part 50
let rec count_some list =
match list with
| [] -> 0
| x :: tl when Option.is_none x -> count_some tl
| x :: tl when Option.is_some x -> 1 + count_some tl
| x :: tl -> -1 (* unreachable *)
;;
#part 51
let rec count_some list =
match list with
| [] -> 0
| x :: tl when Option.is_none x -> count_some tl
| _ :: tl -> 1 + count_some tl
;;
#part 52
let rec count_some list =
match list with
| [] -> 0
| None :: tl -> count_some tl
| Some _ :: tl -> 1 + count_some tl
;;
#part 53
let count_some l = List.count ~f:Option.is_some l;;
#part 54
#part 55
#part 56
#part 57
#part 58
#part 59
#part 60
#part 61
#part 62
#part 63
#part 64
#part 65
#part 66
#part 67
#part 68
#part 69
printf "%s\n"
(render_table
["language";"architect";"first release"]
[ ["Lisp" ;"John McCarthy" ;"1958"] ;
["C" ;"Dennis Ritchie";"1969"] ;
["ML" ;"Robin Milner" ;"1973"] ;
["OCaml";"Xavier Leroy" ;"1996"] ;
]);;
================================================
FILE: code/maps-and-hash-tables/comparable.ml
================================================
module type Comparable = sig
type t
val sexp_of_t : t -> Sexp.t
val t_of_sexp : Sexp.t -> t
val compare : t -> t -> int
end
================================================
FILE: code/maps-and-hash-tables/core_phys_equal.topscript
================================================
open Core.Std ;;
1 == 2 ;;
phys_equal 1 2 ;;
================================================
FILE: code/maps-and-hash-tables/main-22.rawscript
================================================
# module Foo_and_bar : sig
type t = { foo: Int.Set.t; bar: string }
include Comparable.S with type t := t
end = struct
module T = struct
type t = { foo: Int.Set.t; bar: string } with sexp
let compare t1 t2 =
let c = Int.Set.compare t1.foo t2.foo in
if c <> 0 then c else String.compare t1.bar t2.bar
end
include T
include Comparable.Make(T)
end;;
module Foo_and_bar :
sig
type t = { foo : Int.Set.t; bar : string; }
val ( >= ) : t -> t -> bool
val ( <= ) : t -> t -> bool
val ( = ) : t -> t -> bool
...
end
================================================
FILE: code/maps-and-hash-tables/main-23.rawscript
================================================
# module Foo_and_bar : sig
type t = { foo: Int.Set.t; bar: string }
include Comparable.S with type t := t
end = struct
module T = struct
type t = { foo: Int.Set.t; bar: string } with sexp, compare
end
include T
include Comparable.Make(T)
end;;
module Foo_and_bar :
sig
type t = { foo : Int.Set.t; bar : string; }
val ( >= ) : t -> t -> bool
val ( <= ) : t -> t -> bool
val ( = ) : t -> t -> bool
...
end
================================================
FILE: code/maps-and-hash-tables/main-24.rawscript
================================================
# module Foo_and_bar : sig
type t = { foo: int; bar: string }
include Comparable.S with type t := t
end = struct
module T = struct
type t = { foo: int; bar: string } with sexp
end
include T
include Comparable.Poly(T)
end;;
module Foo_and_bar :
sig
type t = { foo : int; bar : string; }
val ( >= ) : t -> t -> bool
val ( <= ) : t -> t -> bool
val ( = ) : t -> t -> bool
...
end
================================================
FILE: code/maps-and-hash-tables/main-30.rawscript
================================================
# module Foo_and_bar : sig
type t = { foo: int; bar: string }
include Hashable.S with type t := t
end = struct
module T = struct
type t = { foo: int; bar: string } with sexp, compare
let hash t =
(Int.hash t.foo) lxor (String.hash t.bar)
end
include T
include Hashable.Make(T)
end;;
module Foo_and_bar :
sig
type t = { foo : int; bar : string; }
module Hashable : sig type t = t end
val hash : t -> int
val compare : t -> t -> int
val hashable : t Pooled_hashtbl.Hashable.t
...
end
================================================
FILE: code/maps-and-hash-tables/main.topscript
================================================
let x = 0;;
#part 1
let digit_alist =
[ 0, "zero"; 1, "one"; 2, "two" ; 3, "three"; 4, "four"
; 5, "five"; 6, "six"; 7, "seven"; 8, "eight"; 9, "nine" ]
;;
#part 2
List.Assoc.find digit_alist 6;;
List.Assoc.find digit_alist 22;;
List.Assoc.add digit_alist 0 "zilch";;
#part 3
let digit_map = Map.of_alist_exn digit_alist
~comparator:Int.comparator;;
Map.find digit_map 3;;
#part 4
let zilch_map = Map.add digit_map ~key:0 ~data:"zilch";;
#part 5
let left = String.Map.of_alist_exn ["foo",1; "bar",3; "snoo", 0]
let right = String.Map.of_alist_exn ["foo",0; "snoo", 0]
let diff = Map.symmetric_diff ~data_equal:Int.equal left right
;;
#part 6
Map.symmetric_diff;;
#part 7
module Reverse = Comparator.Make(struct
type t = string
let sexp_of_t = String.sexp_of_t
let t_of_sexp = String.t_of_sexp
let compare x y = String.compare y x
end);;
#part 8
let alist = ["foo", 0; "snoo", 3];;
let ord_map = Map.of_alist_exn ~comparator:String.comparator alist;;
let rev_map = Map.of_alist_exn ~comparator:Reverse.comparator alist;;
#part 9
Map.min_elt ord_map;;
Map.min_elt rev_map;;
#part 10
Map.symmetric_diff ord_map rev_map;;
#part 11
let ord_tree = Map.to_tree ord_map;;
#part 12
Map.Tree.find ~comparator:String.comparator ord_tree "snoo";;
#part 13
Map.Tree.find ~comparator:Reverse.comparator ord_tree "snoo";;
#part 14
Map.of_alist_exn ~comparator:Comparator.Poly.comparator digit_alist;;
#part 15
Map.Poly.of_alist_exn digit_alist;;
#part 16
Map.symmetric_diff (Map.Poly.singleton 3 "three")
(Int.Map.singleton 3 "four" ) ;;
#part 17
let dedup ~comparator l =
List.fold l ~init:(Set.empty ~comparator) ~f:Set.add
|> Set.to_list
;;
dedup ~comparator:Int.comparator [8;3;2;3;7;8;10];;
#part 18
let (s1,s2) = (Int.Set.of_list [1;2],
Int.Set.of_list [2;1]);;
#part 19
Set.equal s1 s2;;
#part 20
s1 = s2;;
#part 21
Set.to_tree s1 = Set.to_tree s2;;
#part 22
module Foo_and_bar : sig
type t = { foo: Int.Set.t; bar: string }
include Comparable.S with type t := t
end = struct
module T = struct
type t = { foo: Int.Set.t; bar: string } with sexp
let compare t1 t2 =
let c = Int.Set.compare t1.foo t2.foo in
if c <> 0 then c else String.compare t1.bar t2.bar
end
include T
include Comparable.Make(T)
end;;
#part 23
module Foo_and_bar : sig
type t = { foo: Int.Set.t; bar: string }
include Comparable.S with type t := t
end = struct
module T = struct
type t = { foo: Int.Set.t; bar: string } with sexp, compare
end
include T
include Comparable.Make(T)
end;;
#part 24
module Foo_and_bar : sig
type t = { foo: int; bar: string }
include Comparable.S with type t := t
end = struct
module T = struct
type t = { foo: int; bar: string } with sexp
end
include T
include Comparable.Poly(T)
end;;
#part 25
let table = Hashtbl.create ~hashable:String.hashable ();;
Hashtbl.replace table ~key:"three" ~data:3;;
Hashtbl.find table "three";;
#part 26
let table = String.Table.create ();;
#part 27
let table = Hashtbl.create ~hashable:Hashtbl.Poly.hashable ();;
#part 28
let table = Hashtbl.Poly.create ();;
#part 29
Caml.Hashtbl.hash (List.range 0 9);;
Caml.Hashtbl.hash (List.range 0 10);;
Caml.Hashtbl.hash (List.range 0 11);;
Caml.Hashtbl.hash (List.range 0 100);;
#part 30
module Foo_and_bar : sig
type t = { foo: int; bar: string }
include Hashable.S with type t := t
end = struct
module T = struct
type t = { foo: int; bar: string } with sexp, compare
let hash t =
(Int.hash t.foo) lxor (String.hash t.bar)
end
include T
include Hashable.Make(T)
end;;
================================================
FILE: code/maps-and-hash-tables/map_vs_hash.ml
================================================
open Core.Std
open Core_bench.Std
let map_iter ~num_keys ~iterations =
let rec loop i map =
if i <= 0 then ()
else loop (i - 1)
(Map.change map (i mod num_keys) (fun current ->
Some (1 + Option.value ~default:0 current)))
in
loop iterations Int.Map.empty
let table_iter ~num_keys ~iterations =
let table = Int.Table.create ~size:num_keys () in
let rec loop i =
if i <= 0 then ()
else (
Hashtbl.change table (i mod num_keys) (fun current ->
Some (1 + Option.value ~default:0 current));
loop (i - 1)
)
in
loop iterations
let tests ~num_keys ~iterations =
let test name f = Bench.Test.create f ~name in
[ test "map" (fun () -> map_iter ~num_keys ~iterations)
; test "table" (fun () -> table_iter ~num_keys ~iterations)
]
let () =
tests ~num_keys:1000 ~iterations:100_000
|> Bench.make_command
|> Command.run
================================================
FILE: code/maps-and-hash-tables/map_vs_hash2.ml
================================================
open Core.Std
open Core_bench.Std
let create_maps ~num_keys ~iterations =
let rec loop i map =
if i <= 0 then []
else
let new_map =
Map.change map (i mod num_keys) (fun current ->
Some (1 + Option.value ~default:0 current))
in
new_map :: loop (i - 1) new_map
in
loop iterations Int.Map.empty
let create_tables ~num_keys ~iterations =
let table = Int.Table.create ~size:num_keys () in
let rec loop i =
if i <= 0 then []
else (
Hashtbl.change table (i mod num_keys) (fun current ->
Some (1 + Option.value ~default:0 current));
let new_table = Hashtbl.copy table in
new_table :: loop (i - 1)
)
in
loop iterations
let tests ~num_keys ~iterations =
let test name f = Bench.Test.create f ~name in
[ test "map" (fun () -> ignore (create_maps ~num_keys ~iterations))
; test "table" (fun () -> ignore (create_tables ~num_keys ~iterations))
]
let () =
tests ~num_keys:50 ~iterations:1000
|> Bench.make_command
|> Command.run
================================================
FILE: code/maps-and-hash-tables/phys_equal.rawscript
================================================
# type t1 = { foo1:int; bar1:t2 } and t2 = { foo2:int; bar2:t1 } ;;
type t1 = { foo1 : int; bar1 : t2; }
and t2 = { foo2 : int; bar2 : t1; }
# let rec v1 = { foo1=1; bar1=v2 } and v2 = { foo2=2; bar2=v1 } ;;
# v1 == v1;;
- : bool = true
# phys_equal v1 v1;;
- : bool = true
# v1 = v1 ;;
================================================
FILE: code/maps-and-hash-tables/run_map_vs_hash.sh
================================================
corebuild -pkg core_bench map_vs_hash.native
./map_vs_hash.native -ascii -clear-columns time speedup
================================================
FILE: code/maps-and-hash-tables/run_map_vs_hash2.sh
================================================
corebuild -pkg core_bench map_vs_hash2.native
./map_vs_hash2.native -ascii -clear-columns time speedup
================================================
FILE: code/memory-repr/block.ascii
================================================
+------------------------+---------+----------+----------+----------+----
| size of block in words | color | tag byte | value[0] | value[1] | ...
+------------------------+---------+----------+----------+----------+----
<-either 22 or 54 bits-> <-2 bit-> <--8 bit-->
================================================
FILE: code/memory-repr/custom_ops.c
================================================
struct custom_operations {
char *identifier;
void (*finalize)(value v);
int (*compare)(value v1, value v2);
intnat (*hash)(value v);
void (*serialize)(value v,
/*out*/ uintnat * wsize_32 /*size in bytes*/,
/*out*/ uintnat * wsize_64 /*size in bytes*/);
uintnat (*deserialize)(void * dst);
int (*compare_ext)(value v1, value v2);
};
================================================
FILE: code/memory-repr/float_array_layout.ascii
================================================
+---------+----------+----------- - - - -
| header | float[0] | float[1] | ....
+---------+----------+----------+- - - - -
================================================
FILE: code/memory-repr/reprs.topscript
================================================
Obj.is_block (Obj.repr (1,2,3)) ;;
Obj.is_block (Obj.repr 1) ;;
#part 1
Obj.tag (Obj.repr 1.0) ;;
Obj.double_tag ;;
#part 2
Obj.double_tag ;;
Obj.double_array_tag ;;
#part 3
Obj.tag (Obj.repr [| 1.0; 2.0; 3.0 |]) ;;
Obj.tag (Obj.repr (1.0, 2.0, 3.0) ) ;;
Obj.double_field (Obj.repr [| 1.1; 2.2; 3.3 |]) 1 ;;
Obj.double_field (Obj.repr 1.234) 0 ;;
#part 4
type t = Apple | Orange | Pear ;;
((Obj.magic (Obj.repr Apple)) : int) ;;
((Obj.magic (Obj.repr Pear)) : int) ;;
Obj.is_block (Obj.repr Apple) ;;
#part 5
type t = Apple | Orange of int | Pear of string | Kiwi ;;
Obj.is_block (Obj.repr (Orange 1234)) ;;
Obj.tag (Obj.repr (Orange 1234)) ;;
Obj.tag (Obj.repr (Pear "xyz")) ;;
(Obj.magic (Obj.field (Obj.repr (Orange 1234)) 0) : int) ;;
(Obj.magic (Obj.field (Obj.repr (Pear "xyz")) 0) : string) ;;
#part 6
Pa_type_conv.hash_variant "Foo" ;;
(Obj.magic (Obj.repr `Foo) : int) ;;
================================================
FILE: code/memory-repr/simple_record.topscript
================================================
type t = { foo: int; bar: int } ;;
let x = { foo = 13; bar = 14 } ;;
================================================
FILE: code/memory-repr/string_block.ascii
================================================
+---------------+----------------+--------+-----------+
| header | 'a' 'b' 'c' 'd' 'e' 'f' | '\O' '\1' |
+---------------+----------------+--------+-----------+
L data L padding
================================================
FILE: code/memory-repr/string_size_calc.ascii
================================================
number_of_words_in_block * sizeof(word) - last_byte_of_block - 1
================================================
FILE: code/memory-repr/tuple_layout.ascii
================================================
+---------+----------+----------- - - - -
| header | value[0] | value[1] | ....
+---------+----------+----------+- - - - -
================================================
FILE: code/objects/IsBarbell.java
================================================
boolean IsBarbell(Shape[] s) {
return s.length == 3 && (s[0] instanceof Circle) &&
(s[1] instanceof Line) && (s[2] instanceof Circle) &&
((Circle) s[0]).radius() == ((Circle) s[2]).radius();
}
================================================
FILE: code/objects/Shape.java
================================================
String GetShapeName(Shape s) {
if (s instanceof Square) {
return "Square";
} else if (s instanceof Circle) {
return "Circle";
} else {
return "Other";
}
}
================================================
FILE: code/objects/immutable.topscript
================================================
1;;
#part 1
let imm_stack init = object
val v = init
method pop =
match v with
| hd :: tl -> Some (hd, {< v = tl >})
| [] -> None
method push hd =
{< v = hd :: v >}
end ;;
#part 2
let s = imm_stack [3; 2; 1] ;;
let t = s#push 4 ;;
s#pop ;;
t#pop ;;
================================================
FILE: code/objects/is_barbell.ml
================================================
let is_barbell = function
| [Circle r1; Line _; Circle r2] when r1 = r2 -> true
| _ -> false
================================================
FILE: code/objects/narrowing.ml
================================================
(* part 1 *)
type shape = < variant : repr; area : float>
and circle = < variant : repr; area : float; radius : int >
and line = < variant : repr; area : float; length : int >
and repr =
| Circle of circle
| Line of line;;
let is_barbell = function
| [s1; s2; s3] ->
(match s1#variant, s2#variant, s3#variant with
| Circle c1, Line _, Circle c2 when c1#radius = c2#radius -> true
| _ -> false)
| _ -> false;;
================================================
FILE: code/objects/polymorphism.topscript
================================================
1;;
#part 1
let area sq = sq#width * sq#width ;;
let minimize sq : unit = sq#resize 1 ;;
let limit sq =
if (area sq) > 100 then minimize sq ;;
#part 2
let toggle sq b : unit =
if b then sq#resize `Fullscreen
else minimize sq ;;
#part 3
let area_closed (sq: < width : int >) = sq#width * sq#width ;;
let sq = object
method width = 30
method name = "sq"
end ;;
area_closed sq ;;
#part 4
type square = < width : int; ..> ;;
================================================
FILE: code/objects/row_polymorphism.topscript
================================================
type shape = < area : float > ;;
type square = < area : float; width : int > ;;
let square w = object
method area = Float.of_int (w * w)
method width = w
end ;;
type circle = < area : float; radius : int > ;;
let circle r = object
method area = 3.14 *. (Float.of_int r) ** 2.0
method radius = r
end ;;
#part 1
let remove_large l =
List.filter ~f:(fun s -> s#area <= 100.) l ;;
#part 2
let squares : < area : float; width : int > list =
[square 5; square 15; square 10] ;;
remove_large squares ;;
#part 3
let remove_large (l: < area : float > list) =
List.filter ~f:(fun s -> s#area <= 100.) l ;;
remove_large (squares :> < area : float > list ) ;;
#part 4
let hlist: < area: float; ..> list = [square 10; circle 30] ;;
#part 5
let shape_ref: < area: float; ..> ref = ref (square 40) ;;
shape_ref := circle 20 ;;
#part 6
let hlist: shape list = [(square 10 :> shape); (circle 30 :> shape)] ;;
let shape_ref: shape ref = ref (square 40 :> shape) ;;
shape_ref := (circle 20 :> shape) ;;
================================================
FILE: code/objects/stack.topscript
================================================
1;;
#part 1
let s = object
val mutable v = [0; 2]
method pop =
match v with
| hd :: tl ->
v <- tl;
Some hd
| [] -> None
method push hd =
v <- hd :: v
end ;;
#part 2
s#pop ;;
s#push 4 ;;
s#pop ;;
#part 3
let stack init = object
val mutable v = init
method pop =
match v with
| hd :: tl ->
v <- tl;
Some hd
| [] -> None
method push hd =
v <- hd :: v
end ;;
let s = stack [3; 2; 1] ;;
s#pop ;;
#part 4
let print_pop st = Option.iter ~f:(printf "Popped: %d\n") st#pop ;;
print_pop (stack [5;4;3;2;1]) ;;
let t = object
method pop = Some (Float.to_int (Time.to_float (Time.now ())))
end ;;
print_pop t ;;
================================================
FILE: code/objects/subtyping.ml
================================================
(* part 1 *)
type shape = < area : float >
type square = < area : float; width : int >
let square w = object
method area = Float.of_int (w * w)
method width = w
end
type circle = < area : float; radius : int >
let circle r = object
method area = 3.14 *. (Float.of_int r) ** 2.0
method radius = r
end
(* part 2 *)
type 'a stack = < pop: 'a option; push: 'a -> unit >
let square_stack: square stack = stack [square 30; square 10]
let circle_stack: circle stack = stack [circle 20; circle 40]
================================================
FILE: code/objects/subtyping.topscript
================================================
let stack init = object
val mutable v = init
method pop =
match v with
| hd :: tl ->
v <- tl;
Some hd
| [] -> None
method push hd =
v <- hd :: v
end ;;
type shape = < area : float > ;;
type square = < area : float; width : int > ;;
let square w = object
method area = Float.of_int (w * w)
method width = w
end ;;
type circle = < area : float; radius : int > ;;
let circle r = object
method area = 3.14 *. (Float.of_int r) ** 2.0
method radius = r
end ;;
type 'a stack = < pop: 'a option; push: 'a -> unit > ;;
let square_stack: square stack = stack [square 30; square 10] ;;
let circle_stack: circle stack = stack [circle 20; circle 40] ;;
#part 1
let shape w : shape = square w ;;
let shape w : shape = (square w :> shape) ;;
#part 2
let coin = object
method shape = circle 5
method color = "silver"
end ;;
let map = object
method shape = square 10
end ;;
#part 3
type item = < shape : shape > ;;
let items = [ (coin :> item) ; (map :> item) ] ;;
#part 4
type num = [ `Int of int | `Float of float ] ;;
type const = [ num | `String of string ] ;;
let n : num = `Int 3 ;;
let c : const = (n :> const) ;;
#part 5
let squares: square list = [ square 10; square 20 ] ;;
let shapes: shape list = (squares :> shape list) ;;
#part 6
let square_array: square array = [| square 10; square 20 |] ;;
let shape_array: shape array = (square_array :> shape array) ;;
#part 7
let shape_to_string: shape -> string =
fun s -> sprintf "Shape(%F)" s#area ;;
let square_to_string: square -> string =
(shape_to_string :> square -> string) ;;
#part 8
module Either = struct
type ('a, 'b) t =
| Left of 'a
| Right of 'b
let left x = Left x
let right x = Right x
end ;;
(Either.left (square 40) :> (shape, shape) Either.t) ;;
#part 9
module AbstractEither : sig
type ('a, 'b) t
val left: 'a -> ('a, 'b) t
val right: 'b -> ('a, 'b) t
end = Either ;;
(AbstractEither.left (square 40) :> (shape, shape) AbstractEither.t) ;;
#part 10
module VarEither : sig
type (+'a, +'b) t
val left: 'a -> ('a, 'b) t
val right: 'b -> ('a, 'b) t
end = Either ;;
(VarEither.left (square 40) :> (shape, shape) VarEither.t) ;;
#part 11
let total_area (shape_stacks: shape stack list) =
let stack_area acc st =
let rec loop acc =
match st#pop with
| Some s -> loop (acc +. s#area)
| None -> acc
in
loop acc
in
List.fold ~init:0.0 ~f:stack_area shape_stacks ;;
#part 12
total_area [(square_stack :> shape stack); (circle_stack :> shape stack)] ;;
#part 13
type 'a readonly_stack = < pop : 'a option > ;;
let total_area (shape_stacks: shape readonly_stack list) =
let stack_area acc st =
let rec loop acc =
match st#pop with
| Some s -> loop (acc +. s#area)
| None -> acc
in
loop acc
in
List.fold ~init:0.0 ~f:stack_area shape_stacks ;;
total_area [(square_stack :> shape readonly_stack); (circle_stack :> shape readonly_stack)] ;;
================================================
FILE: code/ocp-index/index_ncurses.sh
================================================
corebuild -pkg ctypes.foreign -tag bin_annot ncurses.cmi
ocp-index complete -I . Ncur
ocp-index complete -I . Ncurses.a
ocp-index complete -I . Ncurses.
================================================
FILE: code/packing/A.ml
================================================
let v = "hello"
================================================
FILE: code/packing/B.ml
================================================
let w = 42
================================================
FILE: code/packing/X.mlpack
================================================
A
B
================================================
FILE: code/packing/_tags
================================================
<*.cmx> and not "X.cmx": for-pack(X)
================================================
FILE: code/packing/build_test.sh
================================================
corebuild test.inferred.mli test.cmi
cat _build/test.inferred.mli
ocamlobjinfo _build/test.cmi
================================================
FILE: code/packing/show_files.sh
================================================
cat A.ml
cat B.ml
cat _tags
cat X.mlpack
================================================
FILE: code/packing/test.ml
================================================
let v = X.A.v
let w = X.B.w
================================================
FILE: code/parsing/basic_parser.mly
================================================
%token INT
%token FLOAT
%token ID
%token STRING
%token TRUE
%token FALSE
%token NULL
%token LEFT_BRACE
%token RIGHT_BRACE
%token LEFT_BRACK
%token RIGHT_BRACK
%token COLON
%token COMMA
%token EOF
%start exp
%%
exp: { () }
================================================
FILE: code/parsing/build_short_parser.sh
================================================
corebuild -use-menhir short_parser.mli
================================================
FILE: code/parsing/example.json
================================================
{
"title": "Cities",
"cities": [
{ "name": "Chicago", "zips": [60601] },
{ "name": "New York", "zips": [10004] }
]
}
================================================
FILE: code/parsing/json.ml
================================================
type value = [
| `Assoc of (string * value) list
| `Bool of bool
| `Float of float
| `Int of int
| `List of value list
| `Null
| `String of string
]
(* part 1 *)
open Core.Std
let rec output_value outc = function
| `Assoc obj -> print_assoc outc obj
| `List l -> print_list outc l
| `String s -> printf "\"%s\"" s
| `Int i -> printf "%d" i
| `Float x -> printf "%f" x
| `Bool true -> output_string outc "true"
| `Bool false -> output_string outc "false"
| `Null -> output_string outc "null"
and print_assoc outc obj =
output_string outc "{ ";
let sep = ref "" in
List.iter ~f:(fun (key, value) ->
printf "%s\"%s\": %a" !sep key output_value value;
sep := ",\n ") obj;
output_string outc " }"
and print_list outc arr =
output_string outc "[";
List.iteri ~f:(fun i v ->
if i > 0 then
output_string outc ", ";
output_value outc v) arr;
output_string outc "]"
================================================
FILE: code/parsing/lex.syntax
================================================
{ OCaml code }
let definitions...
rules...
{ OCaml code }
================================================
FILE: code/parsing/lexer.mll
================================================
{
open Lexing
open Parser
exception SyntaxError of string
let next_line lexbuf =
let pos = lexbuf.lex_curr_p in
lexbuf.lex_curr_p <-
{ pos with pos_bol = lexbuf.lex_curr_pos;
pos_lnum = pos.pos_lnum + 1
}
}
(* part 1 *)
let int = '-'? ['0'-'9'] ['0'-'9']*
(* part 2 *)
let digit = ['0'-'9']
let frac = '.' digit*
let exp = ['e' 'E'] ['-' '+']? digit+
let float = digit* frac? exp?
(* part 3 *)
let white = [' ' '\t']+
let newline = '\r' | '\n' | "\r\n"
let id = ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']*
(* part 4 *)
rule read =
parse
| white { read lexbuf }
| newline { next_line lexbuf; read lexbuf }
| int { INT (int_of_string (Lexing.lexeme lexbuf)) }
| float { FLOAT (float_of_string (Lexing.lexeme lexbuf)) }
| "true" { TRUE }
| "false" { FALSE }
| "null" { NULL }
| '"' { read_string (Buffer.create 17) lexbuf }
| '{' { LEFT_BRACE }
| '}' { RIGHT_BRACE }
| '[' { LEFT_BRACK }
| ']' { RIGHT_BRACK }
| ':' { COLON }
| ',' { COMMA }
| _ { raise (SyntaxError ("Unexpected char: " ^ Lexing.lexeme lexbuf)) }
| eof { EOF }
(* part 5 *)
and read_string buf =
parse
| '"' { STRING (Buffer.contents buf) }
| '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf }
| '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf }
| '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf }
| '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf }
| '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf }
| '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf }
| '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf }
| [^ '"' '\\']+
{ Buffer.add_string buf (Lexing.lexeme lexbuf);
read_string buf lexbuf
}
| _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) }
| eof { raise (SyntaxError ("String is not terminated")) }
================================================
FILE: code/parsing/lexer_int_fragment.mll
================================================
| int { INT (int_of_string (Lexing.lexeme lexbuf)) }
================================================
FILE: code/parsing/manual_token_type.ml
================================================
type token =
| NULL
| TRUE
| FALSE
| STRING of string
| INT of int
| FLOAT of float
| ID of string
| LEFT_BRACK
| RIGHT_BRACK
| LEFT_BRACE
| RIGHT_BRACE
| COMMA
| COLON
| EOF
================================================
FILE: code/parsing/parsed_example.ml
================================================
`Assoc
["title", `String "Cities";
"cities", `List
[`Assoc ["name", `String "Chicago"; "zips", `List [`Int 60601]];
`Assoc ["name", `String "New York"; "zips", `List [`Int 10004]]]]
================================================
FILE: code/parsing/parser.mly
================================================
%token INT
%token FLOAT
%token ID
%token STRING
%token TRUE
%token FALSE
%token NULL
%token LEFT_BRACE
%token RIGHT_BRACE
%token LEFT_BRACK
%token RIGHT_BRACK
%token COLON
%token COMMA
%token EOF
(* part 1 *)
%start prog
%%
(* part 2 *)
prog:
| EOF { None }
| v = value { Some v }
;
(* part 3 *)
value:
| LEFT_BRACE; obj = object_fields; RIGHT_BRACE
{ `Assoc obj }
| LEFT_BRACK; vl = array_values; RIGHT_BRACK
{ `List vl }
| s = STRING
{ `String s }
| i = INT
{ `Int i }
| x = FLOAT
{ `Float x }
| TRUE
{ `Bool true }
| FALSE
{ `Bool false }
| NULL
{ `Null }
;
(* part 4 *)
object_fields: obj = rev_object_fields { List.rev obj };
rev_object_fields:
| (* empty *) { [] }
| obj = rev_object_fields; COMMA; k = ID; COLON; v = value
{ (k, v) :: obj }
;
(* part 5 *)
array_values:
| (* empty *) { [] }
| vl = rev_values { List.rev vl }
;
rev_values:
| v = value { [v] }
| vl = rev_values; COMMA; v = value
{ v :: vl }
;
================================================
FILE: code/parsing/production.syntax
================================================
symbol: [ id1 = ] symbol1; [ id2 = ] symbol2; ...; [ idN = ] symbolN
{ OCaml code }
================================================
FILE: code/parsing/prog.mli
================================================
val prog:(Lexing.lexbuf -> token) -> Lexing.lexbuf -> Json.value option
================================================
FILE: code/parsing/quadratic_rule.mly
================================================
%token INT
%token FLOAT
%token ID
%token STRING
%token TRUE
%token FALSE
%token NULL
%token LEFT_BRACE
%token RIGHT_BRACE
%token LEFT_BRACK
%token RIGHT_BRACK
%token COLON
%token COMMA
%token EOF
(* part 1 *)
%start prog
%%
(* part 2 *)
prog:
| EOF { None }
| v = value { Some v }
;
(* part 3 *)
value:
| LEFT_BRACE; obj = object_fields; RIGHT_BRACE
{ `Assoc obj }
| LEFT_BRACK; vl = array_values; RIGHT_BRACK
{ `List vl }
| s = STRING
{ `String s }
| i = INT
{ `Int i }
| x = FLOAT
{ `Float x }
| TRUE
{ `Bool true }
| FALSE
{ `Bool false }
| NULL
{ `Null }
;
(* part 4 *)
(* Quadratic left-recursive rule *)
object_fields:
| (* empty *) { [] }
| obj = object_fields; COMMA; k = ID; COLON; v = value
{ obj @ [k, v] }
;
(* part 5 *)
array_values:
| (* empty *) { [] }
| vl = rev_values
{ List.rev vl }
;
rev_values:
| v = value { [v] }
| vl = rev_values; COMMA; v = value
{ v :: vl }
;
================================================
FILE: code/parsing/right_rec_rule.mly
================================================
%token INT
%token FLOAT
%token ID
%token STRING
%token TRUE
%token FALSE
%token NULL
%token LEFT_BRACE
%token RIGHT_BRACE
%token LEFT_BRACK
%token RIGHT_BRACK
%token COLON
%token COMMA
%token EOF
(* part 1 *)
%start prog
%%
(* part 2 *)
prog:
| EOF { None }
| v = value { Some v }
;
(* part 3 *)
value:
| LEFT_BRACE; obj = object_fields; RIGHT_BRACE
{ `Assoc obj }
| LEFT_BRACK; vl = array_values; RIGHT_BRACK
{ `List vl }
| s = STRING
{ `String s }
| i = INT
{ `Int i }
| x = FLOAT
{ `Float x }
| TRUE
{ `Bool true }
| FALSE
{ `Bool false }
| NULL
{ `Null }
;
(* part 4 *)
(* Inefficient right-recursive rule *)
object_fields:
| (* empty *) { [] }
| k = ID; COLON; v = value; COMMA; obj = object_fields
{ (k, v) :: obj }
(* part 5 *)
array_values: /* empty */
{ [] }
| vl = rev_values
{ List.rev vl }
;
rev_values: v = value
{ [v] }
| vl = rev_values; COMMA; v = value
{ v :: vl }
;
================================================
FILE: code/parsing/short_parser.mly
================================================
%token INT
%token FLOAT
%token STRING
%token TRUE
%token FALSE
%token NULL
%token LEFT_BRACE
%token RIGHT_BRACE
%token LEFT_BRACK
%token RIGHT_BRACK
%token COLON
%token COMMA
%token EOF
%start prog
%%
(* part 1 *)
prog:
| v = value { Some v }
| EOF { None } ;
value:
| LEFT_BRACE; obj = obj_fields; RIGHT_BRACE { `Assoc obj }
| LEFT_BRACK; vl = list_fields; RIGHT_BRACK { `List vl }
| s = STRING { `String s }
| i = INT { `Int i }
| x = FLOAT { `Float x }
| TRUE { `Bool true }
| FALSE { `Bool false }
| NULL { `Null } ;
obj_fields:
obj = separated_list(COMMA, obj_field) { obj } ;
obj_field:
k = STRING; COLON; v = value { (k, v) } ;
list_fields:
vl = separated_list(COMMA, value) { vl } ;
================================================
FILE: code/parsing/tokenized_example.ml
================================================
================================================
FILE: code/parsing/tokens.ml
================================================
[ LEFT_BRACE; ID("title"); COLON; STRING("Cities"); COMMA; ID("cities"); ...
================================================
FILE: code/parsing/yacc.syntax
================================================
%%
%%
================================================
FILE: code/parsing-test/build_json_parser.sh
================================================
corebuild -use-menhir parser.mli
================================================
FILE: code/parsing-test/build_test.sh
================================================
ocamlbuild -use-menhir -tag thread -use-ocamlfind -quiet -pkg core test.native
./test.native test1.json
================================================
FILE: code/parsing-test/run_broken_test.errsh
================================================
cat test2.json
./test.native test2.json
================================================
FILE: code/parsing-test/test.ml
================================================
open Core.Std
open Lexer
open Lexing
let print_position outx lexbuf =
let pos = lexbuf.lex_curr_p in
fprintf outx "%s:%d:%d" pos.pos_fname
pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1)
let parse_with_error lexbuf =
try Parser.prog Lexer.read lexbuf with
| SyntaxError msg ->
fprintf stderr "%a: %s\n" print_position lexbuf msg;
None
| Parser.Error ->
fprintf stderr "%a: syntax error\n" print_position lexbuf;
exit (-1)
(* part 1 *)
let rec parse_and_print lexbuf =
match parse_with_error lexbuf with
| Some value ->
printf "%a\n" Json.output_value value;
parse_and_print lexbuf
| None -> ()
let loop filename () =
let inx = In_channel.create filename in
let lexbuf = Lexing.from_channel inx in
lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename };
parse_and_print lexbuf;
In_channel.close inx
(* part 2 *)
let () =
Command.basic ~summary:"Parse and display JSON"
Command.Spec.(empty +> anon ("filename" %: file))
loop
|> Command.run
================================================
FILE: code/parsing-test/test1.json
================================================
true
false
null
[1, 2, 3., 4.0, .5, 5.5e5, 6.3]
"Hello World"
{ "field1": "Hello",
"field2": 17e13,
"field3": [1, 2, 3],
"field4": { "fieldA": 1, "fieldB": "Hello" }
}
================================================
FILE: code/parsing-test/test2.json
================================================
{ "name": "Chicago",
"zips": [12345,
}
{ "name": "New York",
"zips": [10004]
}
================================================
FILE: code/principal/build_principal.sh
================================================
corebuild -tag principal principal.cmi non_principal.cmi
================================================
FILE: code/records/functional_update.syntax
================================================
{ with = ;
= ;
...
}
================================================
FILE: code/records/main-29.rawscript
================================================
# module Logon = struct
type t =
{ session_id: string;
time: Time.t;
user: string;
credentials: string;
}
with fields
end;;
module Logon :
sig
type t = {
session_id : string;
time : Time.t;
user : string;
credentials : string;
}
val credentials : t -> string
val user : t -> string
val time : t -> Time.t
val session_id : t -> string
module Fields :
sig
val names : string list
val credentials :
([< `Read | `Set_and_create ], t, string) Field.t_with_perm
val user :
([< `Read | `Set_and_create ], t, string) Field.t_with_perm
val time :
([< `Read | `Set_and_create ], t, Time.t) Field.t_with_perm
val session_id :
([< `Read | `Set_and_create ], t, string) Field.t_with_perm
[ ... many definitions omitted ... ]
end
end
================================================
FILE: code/records/main.topscript
================================================
type host_info =
{ hostname : string;
os_name : string;
cpu_arch : string;
timestamp : Time.t;
};;
#part 1
#require "core_extended";;
open Core_extended.Std;;
let my_host =
let sh = Shell.sh_one_exn in
{ hostname = sh "hostname";
os_name = sh "uname -s";
cpu_arch = sh "uname -p";
timestamp = Time.now ();
};;
#part 2
my_host.cpu_arch;;
#part 3
type 'a timestamped = { item: 'a; time: Time.t };;
#part 4
let first_timestamped list =
List.reduce list ~f:(fun a b -> if a.time < b.time then a else b)
;;
#part 5
let host_info_to_string { hostname = h; os_name = os;
cpu_arch = c; timestamp = ts;
} =
sprintf "%s (%s / %s, on %s)" h os c (Time.to_sec_string ts);;
host_info_to_string my_host;;
#part 6
type host_info =
{ hostname : string;
os_name : string;
cpu_arch : string;
os_release : string;
timestamp : Time.t;
} ;;
#part 7
#warnings "+9";;
let host_info_to_string { hostname = h; os_name = os;
cpu_arch = c; timestamp = ts;
} =
sprintf "%s (%s / %s, on %s)" h os c (Time.to_sec_string ts);;
#part 8
let host_info_to_string { hostname = h; os_name = os;
cpu_arch = c; timestamp = ts; _
} =
sprintf "%s (%s / %s, on %s)" h os c (Time.to_sec_string ts);;
#part 9
let host_info_to_string { hostname; os_name; cpu_arch; timestamp; _ } =
sprintf "%s (%s / %s) <%s>" hostname os_name cpu_arch
(Time.to_string timestamp);;
#part 10
let my_host =
let sh cmd = Shell.sh_one_exn cmd in
let hostname = sh "hostname" in
let os_name = sh "uname -s" in
let cpu_arch = sh "uname -p" in
let os_release = sh "uname -r" in
let timestamp = Time.now () in
{ hostname; os_name; cpu_arch; os_release; timestamp };;
#part 11
let create_host_info ~hostname ~os_name ~cpu_arch ~os_release =
{ os_name; cpu_arch; os_release;
hostname = String.lowercase hostname;
timestamp = Time.now () };;
#part 12
let create_host_info
~hostname:hostname ~os_name:os_name
~cpu_arch:cpu_arch ~os_release:os_release =
{ os_name = os_name;
cpu_arch = cpu_arch;
os_release = os_release;
hostname = String.lowercase hostname;
timestamp = Time.now () };;
#part 13
type log_entry =
{ session_id: string;
time: Time.t;
important: bool;
message: string;
}
type heartbeat =
{ session_id: string;
time: Time.t;
status_message: string;
}
type logon =
{ session_id: string;
time: Time.t;
user: string;
credentials: string;
}
;;
#part 14
let get_session_id t = t.session_id;;
#part 15
let get_heartbeat_session_id (t:heartbeat) = t.session_id;;
#part 16
let status_and_session t = (t.status_message, t.session_id);;
let session_and_status t = (t.session_id, t.status_message);;
let session_and_status (t:heartbeat) = (t.session_id, t.status_message);;
#part 17
module Log_entry = struct
type t =
{ session_id: string;
time: Time.t;
important: bool;
message: string;
}
end
module Heartbeat = struct
type t =
{ session_id: string;
time: Time.t;
status_message: string;
}
end
module Logon = struct
type t =
{ session_id: string;
time: Time.t;
user: string;
credentials: string;
}
end;;
#part 18
let create_log_entry ~session_id ~important message =
{ Log_entry.time = Time.now (); Log_entry.session_id;
Log_entry.important; Log_entry.message }
;;
#part 19
let create_log_entry ~session_id ~important message =
{ Log_entry.
time = Time.now (); session_id; important; message }
;;
#part 20
let message_to_string { Log_entry.important; message; _ } =
if important then String.uppercase message else message
;;
#part 21
let is_important t = t.Log_entry.important;;
#part 22
type client_info =
{ addr: Unix.Inet_addr.t;
port: int;
user: string;
credentials: string;
last_heartbeat_time: Time.t;
};;
let register_heartbeat t hb =
{ addr = t.addr;
port = t.port;
user = t.user;
credentials = t.credentials;
last_heartbeat_time = hb.Heartbeat.time;
};;
#part 23
let register_heartbeat t hb =
{ t with last_heartbeat_time = hb.Heartbeat.time };;
#part 24
type client_info =
{ addr: Unix.Inet_addr.t;
port: int;
user: string;
credentials: string;
last_heartbeat_time: Time.t;
last_heartbeat_status: string;
};;
#part 25
let register_heartbeat t hb =
{ t with last_heartbeat_time = hb.Heartbeat.time;
last_heartbeat_status = hb.Heartbeat.status_message;
};;
#part 26
type client_info =
{ addr: Unix.Inet_addr.t;
port: int;
user: string;
credentials: string;
mutable last_heartbeat_time: Time.t;
mutable last_heartbeat_status: string;
};;
#part 27
let register_heartbeat t hb =
t.last_heartbeat_time <- hb.Heartbeat.time;
t.last_heartbeat_status <- hb.Heartbeat.status_message
;;
#part 28
let get_users logons =
List.dedup (List.map logons ~f:(fun x -> x.Logon.user));;
#part 29
module Logon = struct
type t =
{ session_id: string;
time: Time.t;
user: string;
credentials: string;
}
with fields
end;;
#part 30
let get_users logons = List.dedup (List.map logons ~f:Logon.user);;
#part 31
Field.get Logon.Fields.user;;
#part 32
Field.get;;
#part 33
let show_field field to_string record =
let name = Field.name field in
let field_string = to_string (Field.get field record) in
name ^ ": " ^ field_string
;;
#part 34
let logon = { Logon.
session_id = "26685";
time = Time.now ();
user = "yminsky";
credentials = "Xy2d9W"; }
;;
show_field Logon.Fields.user Fn.id logon;;
show_field Logon.Fields.time Time.to_string logon;;
#part 35
Logon.Fields.iter;;
#part 36
let print_logon logon =
let print to_string field =
printf "%s\n" (show_field field to_string logon)
in
Logon.Fields.iter
~session_id:(print Fn.id)
~time:(print Time.to_string)
~user:(print Fn.id)
~credentials:(print Fn.id)
;;
print_logon logon;;
#part 37
#part 38
#part 39
#part 40
#part 41
#part 42
#part 43
#part 44
#part 45
#part 46
#part 47
#part 48
#part 49
#part 50
================================================
FILE: code/records/record.syntax
================================================
type =
{ : ;
: ;
...
}
================================================
FILE: code/records/warn_help.sh
================================================
ocaml -warn-help | egrep '\b9\b'
================================================
FILE: code/sexpr/auto_making_sexp.topscript
================================================
type t = { foo: int; bar: float } with sexp ;;
t_of_sexp (Sexp.of_string "((bar 35) (foo 3))") ;;
#part 1
exception Bad_message of string list ;;
Exn.to_string (Bad_message ["1";"2";"3"]) ;;
exception Good_message of string list with sexp;;
Exn.to_string (Good_message ["1";"2";"3"]) ;;
================================================
FILE: code/sexpr/basic.scm
================================================
(this (is an) (s expression))
================================================
FILE: code/sexpr/build_read_foo.errsh
================================================
corebuild read_foo.native
./read_foo.native foo_example_broken.scm
================================================
FILE: code/sexpr/build_read_foo_better_errors.errsh
================================================
corebuild read_foo_better_errors.native
./read_foo_better_errors.native foo_example_broken.scm
================================================
FILE: code/sexpr/build_test_interval.sh
================================================
corebuild test_interval.native
./test_interval.native
================================================
FILE: code/sexpr/build_test_interval_manual_sexp.sh
================================================
corebuild test_interval_manual_sexp.native
================================================
FILE: code/sexpr/build_test_interval_nosexp.errsh
================================================
corebuild test_interval_nosexp.native
================================================
FILE: code/sexpr/comment_heavy.scm
================================================
;; comment_heavy_example.scm
((this is included)
; (this is commented out
(this stays)
#; (all of this is commented
out (even though it crosses lines.))
(and #| block delimiters #| which can be nested |#
will comment out
an arbitrary multi-line block))) |#
now we're done
))
================================================
FILE: code/sexpr/example.scm
================================================
;; example.scm
((foo 3.3) ;; This is a comment
(bar "this is () an \" atom"))
================================================
FILE: code/sexpr/example_broken.scm
================================================
;; example.scm
((foo 3.3) ;; This is a comment
bar "this is () an \" atom"))
================================================
FILE: code/sexpr/example_load.topscript
================================================
Sexp.load_sexp "example.scm" ;;
#part 1
Sexp.load_sexp "comment_heavy.scm" ;;
#part 2
Exn.handle_uncaught ~exit:false (fun () ->
ignore (Sexp.load_sexp "example_broken.scm")) ;;
================================================
FILE: code/sexpr/foo_broken_example.scm
================================================
((a "not-an-integer")
(b "not-an-integer")
(c 1.0))
================================================
FILE: code/sexpr/inline_sexp.topscript
================================================
let l = [(1,"one"); (2,"two")] ;;
List.iter l ~f:(fun x ->
<:sexp_of> x
|> Sexp.to_string
|> print_endline) ;;
================================================
FILE: code/sexpr/int_interval.ml
================================================
(* Module for representing closed integer intervals *)
open Core.Std
(* Invariant: For any Range (x,y), y >= x *)
type t =
| Range of int * int
| Empty
with sexp
let is_empty =
function
| Empty -> true
| Range _ -> false
let create x y =
if x > y then
Empty
else
Range (x,y)
let contains i x =
match i with
| Empty -> false
| Range (low,high) -> x >= low && x <= high
================================================
FILE: code/sexpr/int_interval.mli
================================================
type t with sexp
val is_empty : t -> bool
val create : int -> int -> t
val contains : t -> int -> bool
================================================
FILE: code/sexpr/int_interval_manual_sexp.ml
================================================
(* Module for representing closed integer intervals *)
open Core.Std
(* Invariant: For any Range (x,y), y >= x *)
type t =
| Range of int * int
| Empty
with sexp
let is_empty =
function
| Empty -> true
| Range _ -> false
let create x y =
if x > y then
Empty
else
Range (x,y)
let contains i x =
match i with
| Empty -> false
| Range (low,high) -> x >= low && x <= high
================================================
FILE: code/sexpr/int_interval_manual_sexp.mli
================================================
open Core.Std
type t
val t_of_sexp : Sexp.t -> t
val sexp_of_t : t -> Sexp.t
val is_empty : t -> bool
val create : int -> int -> t
val contains : t -> int -> bool
================================================
FILE: code/sexpr/int_interval_nosexp.ml
================================================
(* Module for representing closed integer intervals *)
open Core.Std
(* Invariant: For any Range (x,y), y >= x *)
type t =
| Range of int * int
| Empty
with sexp
let is_empty =
function
| Empty -> true
| Range _ -> false
let create x y =
if x > y then
Empty
else
Range (x,y)
let contains i x =
match i with
| Empty -> false
| Range (low,high) -> x >= low && x <= high
================================================
FILE: code/sexpr/int_interval_nosexp.mli
================================================
type t
val is_empty : t -> bool
val create : int -> int -> t
val contains : t -> int -> bool
================================================
FILE: code/sexpr/list_top_packages.sh
================================================
ocamlfind list | grep top
================================================
FILE: code/sexpr/manually_making_sexp.topscript
================================================
type t = { foo: int; bar: float } ;;
let sexp_of_t t =
let a x = Sexp.Atom x and l x = Sexp.List x in
l [ l [a "foo"; Int.sexp_of_t t.foo ];
l [a "bar"; Float.sexp_of_t t.bar]; ] ;;
sexp_of_t { foo = 3; bar = -5.5 } ;;
================================================
FILE: code/sexpr/print_sexp.topscript
================================================
Sexp.List [
Sexp.Atom "this";
Sexp.List [ Sexp.Atom "is"; Sexp.Atom "an"];
Sexp.List [ Sexp.Atom "s"; Sexp.Atom "expression" ];
];;
================================================
FILE: code/sexpr/read_foo.ml
================================================
open Core.Std
type t = {
a: string;
b: int;
c: float option
} with sexp
let run () =
let t =
Sexp.load_sexp "foo_broken_example.scm"
|> t_of_sexp
in
printf "b is: %d\n%!" t.b
let () =
Exn.handle_uncaught ~exit:true run
================================================
FILE: code/sexpr/read_foo_better_errors.ml
================================================
open Core.Std
type t = {
a: string;
b: int;
c: float option
} with sexp
let run () =
let t = Sexp.load_sexp_conv_exn "foo_broken_example.scm" t_of_sexp in
printf "b is: %d\n%!" t.b
let () =
Exn.handle_uncaught ~exit:true run
================================================
FILE: code/sexpr/sexp.mli
================================================
module Sexp : sig
type t =
| Atom of string
| List of t list
end
================================================
FILE: code/sexpr/sexp_default.topscript
================================================
type http_server_config = {
web_root: string;
port: int;
addr: string;
} with sexp ;;
#part 1
type http_server_config = {
web_root: string;
port: int with default(80);
addr: string with default("localhost");
} with sexp ;;
#part 2
let cfg = http_server_config_of_sexp
(Sexp.of_string "((web_root /var/www/html))") ;;
#part 3
sexp_of_http_server_config cfg ;;
#part 4
type http_server_config = {
web_root: string;
port: int with default(80), sexp_drop_default;
addr: string with default("localhost"), sexp_drop_default;
} with sexp ;;
let cfg = http_server_config_of_sexp
(Sexp.of_string "((web_root /var/www/html))") ;;
sexp_of_http_server_config cfg ;;
#part 5
sexp_of_http_server_config { cfg with port = 8080 } ;;
sexp_of_http_server_config
{ cfg with port = 8080; addr = "192.168.0.1" } ;;
================================================
FILE: code/sexpr/sexp_list.topscript
================================================
type compatible_versions =
| Specific of string list
| All with sexp ;;
sexp_of_compatible_versions
(Specific ["3.12.0"; "3.12.1"; "3.13.0"]) ;;
#part 1
type compatible_versions =
| Specific of string sexp_list
| All with sexp ;;
sexp_of_compatible_versions
(Specific ["3.12.0"; "3.12.1"; "3.13.0"]) ;;
================================================
FILE: code/sexpr/sexp_opaque.topscript
================================================
type no_converter = int * int ;;
type t = { a: no_converter; b: string } with sexp ;;
#part 1
type t = { a: no_converter sexp_opaque; b: string } with sexp ;;
#part 2
sexp_of_t { a = (3,4); b = "foo" } ;;
#part 3
t_of_sexp (Sexp.of_string "((a whatever) (b foo))") ;;
#part 4
type t = { a: no_converter sexp_opaque list; b: string } with sexp ;;
t_of_sexp (Sexp.of_string "((a ()) (b foo))") ;;
#part 5
type t = { a: no_converter sexp_opaque; b: string } with sexp_of ;;
type t = { a: no_converter sexp_opaque; b: string } with of_sexp ;;
================================================
FILE: code/sexpr/sexp_option.topscript
================================================
type t = { a: int option; b: string } with sexp ;;
sexp_of_t { a = None; b = "hello" } ;;
sexp_of_t { a = Some 3; b = "hello" } ;;
#part 1
type t = { a: int sexp_option; b: string } with sexp ;;
sexp_of_t { a = Some 3; b = "hello" } ;;
sexp_of_t { a = None; b = "hello" } ;;
================================================
FILE: code/sexpr/sexp_override.ml
================================================
type t =
| Range of int * int
| Empty
with sexp
let create x y =
if x > y then Empty else Range (x,y)
let t_of_sexp sexp =
let t = t_of_sexp sexp in
begin match t with
| Empty -> ()
| Range (x,y) ->
if y < x then of_sexp_error "Upper and lower bound of Range swapped" sexp
end;
t
================================================
FILE: code/sexpr/sexp_printer.topscript
================================================
Sexp.to_string (Sexp.List [Sexp.Atom "1"; Sexp.Atom "2"]) ;;
Sexp.of_string ("(1 2 (3 4))") ;;
================================================
FILE: code/sexpr/test_interval.ml
================================================
open Core.Std
let intervals =
let module I = Int_interval in
[ I.create 3 4;
I.create 5 4; (* should be empty *)
I.create 2 3;
I.create 1 6;
]
let () =
intervals
|> List.sexp_of_t Int_interval.sexp_of_t
|> Sexp.to_string_hum
|> print_endline
================================================
FILE: code/sexpr/test_interval_manual_sexp.ml
================================================
open Core.Std
module Int_interval = Int_interval_manual_sexp
let intervals =
let module I = Int_interval in
[ I.create 3 4;
I.create 5 4; (* should be empty *)
I.create 2 3;
I.create 1 6;
]
let () =
intervals
|> List.sexp_of_t Int_interval.sexp_of_t
|> Sexp.to_string_hum
|> print_endline
================================================
FILE: code/sexpr/test_interval_nosexp.ml
================================================
open Core.Std
module Int_interval = Int_interval_nosexp
let intervals =
let module I = Int_interval in
[ I.create 3 4;
I.create 5 4; (* should be empty *)
I.create 2 3;
I.create 1 6;
]
let () =
intervals
|> List.sexp_of_t Int_interval.sexp_of_t
|> Sexp.to_string_hum
|> print_endline
================================================
FILE: code/sexpr/to_from_sexp.topscript
================================================
Int.sexp_of_t 3;;
String.sexp_of_t "hello";;
Exn.sexp_of_t (Invalid_argument "foo");;
#part 1
List.sexp_of_t;;
List.sexp_of_t Int.sexp_of_t [1; 2; 3];;
#part 2
List.t_of_sexp;;
List.t_of_sexp Int.t_of_sexp (Sexp.of_string "(1 2 3)");;
List.t_of_sexp Int.t_of_sexp (Sexp.of_string "(1 2 three)");;
================================================
FILE: code/variables-and-functions/abs_diff.mli
================================================
val abs_diff : int -> (int -> int)
================================================
FILE: code/variables-and-functions/htable_sig1.ml
================================================
val create_hashtable : int -> bool -> ('a,'b) Hashtable.t
================================================
FILE: code/variables-and-functions/htable_sig2.ml
================================================
val create_hashtable :
init_size:int -> allow_shrinking:bool -> ('a,'b) Hashtable.t
================================================
FILE: code/variables-and-functions/let.syntax
================================================
let =
================================================
FILE: code/variables-and-functions/let_in.syntax
================================================
let = in
================================================
FILE: code/variables-and-functions/main.topscript
================================================
let x = 3;;
let y = 4;;
let z = x + y;;
#part 1
let languages = "OCaml,Perl,C++,C";;
let dashed_languages =
let language_list = String.split languages ~on:',' in
String.concat ~sep:"-" language_list
;;
#part 2
language_list;;
#part 3
let languages = "OCaml,Perl,C++,C";;
let dashed_languages =
let languages = String.split languages ~on:',' in
String.concat ~sep:"-" languages
;;
#part 4
languages;;
#part 5
let area_of_ring inner_radius outer_radius =
let pi = acos (-1.) in
let area_of_circle r = pi *. r *. r in
area_of_circle outer_radius -. area_of_circle inner_radius
;;
area_of_ring 1. 3.;;
#part 6
let area_of_ring inner_radius outer_radius =
let pi = acos (-1.) in
let area_of_circle r = pi *. r *. r in
let pi = 0. in
area_of_circle outer_radius -. area_of_circle inner_radius
;;
#part 7
let (ints,strings) = List.unzip [(1,"one"); (2,"two"); (3,"three")];;
#part 8
let upcase_first_entry line =
let (first :: rest) = String.split ~on:',' line in
String.concat ~sep:"," (String.uppercase first :: rest)
;;
#part 9
let upcase_first_entry line =
match String.split ~on:',' line with
| [] -> assert false (* String.split returns at least one element *)
| first :: rest -> String.concat ~sep:"," (String.uppercase first :: rest)
;;
#part 10
(fun x -> x + 1);;
#part 11
(fun x -> x + 1) 7;;
#part 12
List.map ~f:(fun x -> x + 1) [1;2;3];;
#part 13
let increments = [ (fun x -> x + 1); (fun x -> x + 2) ] ;;
List.map ~f:(fun g -> g 5) increments;;
#part 14
let plusone = (fun x -> x + 1);;
plusone 3;;
#part 15
let plusone x = x + 1;;
#part 16
(fun x -> x + 1) 7;;
let x = 7 in x + 1;;
#part 17
let abs_diff x y = abs (x - y);;
abs_diff 3 4;;
#part 18
let abs_diff =
(fun x -> (fun y -> abs (x - y)));;
#part 19
let dist_from_3 = abs_diff 3;;
dist_from_3 8;;
dist_from_3 (-1);;
#part 20
let abs_diff = (fun x y -> abs (x - y));;
#part 21
let abs_diff (x,y) = abs (x - y);;
abs_diff (3,4);;
#part 22
let rec find_first_stutter list =
match list with
| [] | [_] ->
(* only zero or one elements, so no repeats *)
None
| x :: y :: tl ->
if x = y then Some x else find_first_stutter (y::tl)
;;
#part 23
let rec is_even x =
if x = 0 then true else is_odd (x - 1)
and is_odd x =
if x = 0 then false else is_even (x - 1)
;;
List.map ~f:is_even [0;1;2;3;4;5];;
List.map ~f:is_odd [0;1;2;3;4;5];;
#part 24
Int.max 3 4 (* prefix *);;
3 + 4 (* infix *);;
#part 25
(+) 3 4;;
List.map ~f:((+) 3) [4;5;6];;
#part 26
let (+!) (x1,y1) (x2,y2) = (x1 + x2, y1 + y2);;
(3,2) +! (-2,4);;
#part 27
let (***) x y = (x ** y) ** y;;
#part 28
let ( *** ) x y = (x ** y) ** y;;
#part 29
Int.max 3 (-4);;
Int.max 3 -4;;
#part 30
(Int.max 3) - 4;;
#part 31
let (|>) x f = f x ;;
#part 32
let path = "/usr/bin:/usr/local/bin:/bin:/sbin";;
String.split ~on:':' path
|> List.dedup ~compare:String.compare
|> List.iter ~f:print_endline
;;
#part 33
let split_path = String.split ~on:':' path in
let deduped_path = List.dedup ~compare:String.compare split_path in
List.iter ~f:print_endline deduped_path
;;
#part 34
List.iter ~f:print_endline ["Two"; "lines"];;
#part 35
List.iter ~f:print_endline;;
#part 36
let (^>) x f = f x;;
Sys.getenv_exn "PATH"
^> String.split ~on:':' path
^> List.dedup ~compare:String.compare
^> List.iter ~f:print_endline
;;
#part 37
let some_or_zero = function
| Some x -> x
| None -> 0
;;
List.map ~f:some_or_zero [Some 3; None; Some 4];;
#part 38
let some_or_zero num_opt =
match num_opt with
| Some x -> x
| None -> 0
;;
#part 39
let some_or_default default = function
| Some x -> x
| None -> default
;;
some_or_default 3 (Some 5);;
List.map ~f:(some_or_default 100) [Some 3; None; Some 4];;
#part 40
let ratio ~num ~denom = float num /. float denom;;
#part 41
ratio ~num:3 ~denom:10;;
ratio ~denom:10 ~num:3;;
#part 42
let num = 3 in
let denom = 4 in
ratio ~num ~denom;;
#part 43
String.split ~on:':' path
|> List.dedup ~compare:String.compare
|> List.iter ~f:print_endline
;;
#part 44
let apply_to_tuple f (first,second) = f ~first ~second;;
#part 45
let apply_to_tuple_2 f (first,second) = f ~second ~first;;
#part 46
let divide ~first ~second = first / second;;
#part 47
apply_to_tuple_2 divide (3,4);;
#part 48
let apply_to_tuple f (first,second) = f ~first ~second;;
apply_to_tuple divide (3,4);;
#part 49
let concat ?sep x y =
let sep = match sep with None -> "" | Some x -> x in
x ^ sep ^ y
;;
concat "foo" "bar" (* without the optional argument *);;
concat ~sep:":" "foo" "bar" (* with the optional argument *);;
#part 50
let concat ?(sep="") x y = x ^ sep ^ y ;;
#part 51
concat ~sep:":" "foo" "bar" (* provide the optional argument *);;
concat ?sep:(Some ":") "foo" "bar" (* pass an explicit [Some] *);;
#part 52
concat "foo" "bar" (* don't provide the optional argument *);;
concat ?sep:None "foo" "bar" (* explicitly pass `None` *);;
#part 53
let uppercase_concat ?(sep="") a b = concat ~sep (String.uppercase a) b ;;
uppercase_concat "foo" "bar";;
uppercase_concat "foo" "bar" ~sep:":";;
#part 54
let uppercase_concat ?sep a b = concat ?sep (String.uppercase a) b ;;
#part 55
let numeric_deriv ~delta ~x ~y ~f =
let x' = x +. delta in
let y' = y +. delta in
let base = f ~x ~y in
let dx = (f ~x:x' ~y -. base) /. delta in
let dy = (f ~x ~y:y' -. base) /. delta in
(dx,dy)
;;
#part 56
let numeric_deriv ~delta ~x ~y ~f =
let x' = x +. delta in
let y' = y +. delta in
let base = f ~x ~y in
let dx = (f ~y ~x:x' -. base) /. delta in
let dy = (f ~x ~y:y' -. base) /. delta in
(dx,dy)
;;
#part 57
let numeric_deriv ~delta ~x ~y ~(f: x:float -> y:float -> float) =
let x' = x +. delta in
let y' = y +. delta in
let base = f ~x ~y in
let dx = (f ~y ~x:x' -. base) /. delta in
let dy = (f ~x ~y:y' -. base) /. delta in
(dx,dy)
;;
#part 58
let colon_concat = concat ~sep:":";;
colon_concat "a" "b";;
#part 59
let prepend_pound = concat "# ";;
prepend_pound "a BASH comment";;
#part 60
prepend_pound "a BASH comment" ~sep:":";;
#part 61
let concat x ?(sep="") y = x ^ sep ^ y ;;
#part 62
let prepend_pound = concat "# ";;
prepend_pound "a BASH comment";;
prepend_pound "a BASH comment" ~sep:"--- ";;
#part 63
concat "a" "b" ~sep:"=";;
#part 64
let concat x y ?(sep="") = x ^ sep ^ y ;;
#part 65
concat "a" "b";;
#part 66
#part 67
#part 68
#part 69
#part 70
#part 71
#part 72
#part 73
#part 74
#part 75
#part 76
#part 77
#part 78
#part 79
================================================
FILE: code/variables-and-functions/numerical_deriv_alt_sig.mli
================================================
val numeric_deriv :
delta:float ->
x:float -> y:float -> f:(?x:float -> y:float -> float) -> float * float
================================================
FILE: code/variables-and-functions/operators.syntax
================================================
! $ % & * + - . / : < = > ? @ ^ | ~
================================================
FILE: code/variables-and-functions/substring_sig1.ml
================================================
val substring: string -> int -> int -> string
================================================
FILE: code/variables-and-functions/substring_sig2.ml
================================================
val substring: string -> pos:int -> len:int -> string
================================================
FILE: code/variants/blang.topscript
================================================
type 'a expr =
| Base of 'a
| Const of bool
| And of 'a expr list
| Or of 'a expr list
| Not of 'a expr
;;
#part 1
type mail_field = To | From | CC | Date | Subject
type mail_predicate = { field: mail_field;
contains: string }
;;
#part 2
let test field contains = Base { field; contains };;
And [ Or [ test To "doligez"; test CC "doligez" ];
test Subject "runtime";
]
;;
#part 3
let rec eval expr base_eval =
(* a shortcut, so we don't need to repeatedly pass [base_eval]
explicitly to [eval] *)
let eval' expr = eval expr base_eval in
match expr with
| Base base -> base_eval base
| Const bool -> bool
| And exprs -> List.for_all exprs ~f:eval'
| Or exprs -> List.exists exprs ~f:eval'
| Not expr -> not (eval' expr)
;;
#part 4
let and_ l =
if List.mem l (Const false) then Const false
else
match List.filter l ~f:((<>) (Const true)) with
| [] -> Const true
| [ x ] -> x
| l -> And l
let or_ l =
if List.mem l (Const true) then Const true
else
match List.filter l ~f:((<>) (Const false)) with
| [] -> Const false
| [x] -> x
| l -> Or l
let not_ = function
| Const b -> Const (not b)
| e -> Not e
;;
#part 5
let rec simplify = function
| Base _ | Const _ as x -> x
| And l -> and_ (List.map ~f:simplify l)
| Or l -> or_ (List.map ~f:simplify l)
| Not e -> not_ (simplify e)
;;
#part 6
simplify (Not (And [ Or [Base "it's snowing"; Const true];
Base "it's raining"]));;
#part 7
simplify (Not (And [ Or [Base "it's snowing"; Const true];
Not (Not (Base "it's raining"))]));;
#part 8
let not_ = function
| Const b -> Const (not b)
| (Base _ | And _ | Or _ | Not _) as e -> Not e
;;
#part 9
let not_ = function
| Const b -> Const (not b)
| Not e -> e
| (Base _ | And _ | Or _ ) as e -> Not e
;;
================================================
FILE: code/variants/catch_all.topscript
================================================
type basic_color =
| Black | Red | Green | Yellow | Blue | Magenta | Cyan | White ;;
let basic_color_to_int = function
| Black -> 0 | Red -> 1 | Green -> 2 | Yellow -> 3
| Blue -> 4 | Magenta -> 5 | Cyan -> 6 | White -> 7 ;;
#part 1
type color =
| Basic of basic_color (* basic colors *)
| Bold of basic_color (* bold basic colors *)
| RGB of int * int * int (* 6x6x6 color cube *)
| Gray of int (* 24 grayscale levels *)
;;
#part 2
let color_to_int = function
| Basic (basic_color,weight) ->
let base = match weight with Bold -> 8 | Regular -> 0 in
base + basic_color_to_int basic_color
| RGB (r,g,b) -> 16 + b + g * 6 + r * 36
| Gray i -> 232 + i ;;
#part 3
let color_to_int = function
| Basic basic_color -> basic_color_to_int basic_color
| RGB (r,g,b) -> 16 + b + g * 6 + r * 36
| Gray i -> 232 + i ;;
#part 4
let color_to_int = function
| Basic basic_color -> basic_color_to_int basic_color
| Bold basic_color -> 8 + basic_color_to_int basic_color
| RGB (r,g,b) -> 16 + b + g * 6 + r * 36
| Gray i -> 232 + i ;;
#part 5
let oldschool_color_to_int = function
| Basic (basic_color,weight) ->
let base = match weight with Bold -> 8 | Regular -> 0 in
base + basic_color_to_int basic_color
| _ -> basic_color_to_int White;;
================================================
FILE: code/variants/logger.topscript
================================================
module Heartbeat = struct
type t =
{ session_id: string;
time: Time.t;
status_message: string;
}
end
module Logon = struct
type t =
{ session_id: string;
time: Time.t;
user: string;
credentials: string;
}
end;;
#part 1
module Log_entry = struct
type t =
{ session_id: string;
time: Time.t;
important: bool;
message: string;
}
end
;;
#part 2
type client_message = | Logon of Logon.t
| Heartbeat of Heartbeat.t
| Log_entry of Log_entry.t
;;
#part 3
let messages_for_user user messages =
let (user_messages,_) =
List.fold messages ~init:([],String.Set.empty)
~f:(fun ((messages,user_sessions) as acc) message ->
match message with
| Logon m ->
if m.Logon.user = user then
(message::messages, Set.add user_sessions m.Logon.session_id)
else acc
| Heartbeat _ | Log_entry _ ->
let session_id = match message with
| Logon m -> m.Logon.session_id
| Heartbeat m -> m.Heartbeat.session_id
| Log_entry m -> m.Log_entry.session_id
in
if Set.mem user_sessions session_id then
(message::messages,user_sessions)
else acc
)
in
List.rev user_messages
;;
#part 4
module Log_entry = struct
type t = { important: bool;
message: string;
}
end
module Heartbeat = struct
type t = { status_message: string; }
end
module Logon = struct
type t = { user: string;
credentials: string;
}
end ;;
#part 5
type details =
| Logon of Logon.t
| Heartbeat of Heartbeat.t
| Log_entry of Log_entry.t
;;
#part 6
module Common = struct
type t = { session_id: string;
time: Time.t;
}
end ;;
#part 7
let messages_for_user user messages =
let (user_messages,_) =
List.fold messages ~init:([],String.Set.empty)
~f:(fun ((messages,user_sessions) as acc) ((common,details) as message) ->
let session_id = common.Common.session_id in
match details with
| Logon m ->
if m.Logon.user = user then
(message::messages, Set.add user_sessions session_id)
else acc
| Heartbeat _ | Log_entry _ ->
if Set.mem user_sessions session_id then
(message::messages,user_sessions)
else acc
)
in
List.rev user_messages
;;
#part 8
let handle_message server_state (common,details) =
match details with
| Log_entry m -> handle_log_entry server_state (common,m)
| Logon m -> handle_logon server_state (common,m)
| Heartbeat m -> handle_heartbeat server_state (common,m)
;;
================================================
FILE: code/variants/main-2.rawscript
================================================
# let color_by_number number text =
sprintf "\027[38;5;%dm%s\027[0m" number text;;
val color_by_number : int -> string -> string =
# let blue = color_by_number (basic_color_to_int Blue) "Blue";;
val blue : string = "\027[38;5;4mBlue\027[0m"
# printf "Hello %s World!\n" blue;;
Hello Blue World!
================================================
FILE: code/variants/main-5.rawscript
================================================
# let color_print color s =
printf "%s\n" (color_by_number (color_to_int color) s);;
val color_print : color -> string -> unit =
# color_print (Basic (Red,Bold)) "A bold red!";;
A bold red!
# color_print (Gray 4) "A muted gray...";;
A muted gray...
================================================
FILE: code/variants/main.topscript
================================================
type basic_color =
| Black | Red | Green | Yellow | Blue | Magenta | Cyan | White ;;
Cyan ;;
[Blue; Magenta; Red] ;;
#part 1
let basic_color_to_int = function
| Black -> 0 | Red -> 1 | Green -> 2 | Yellow -> 3
| Blue -> 4 | Magenta -> 5 | Cyan -> 6 | White -> 7 ;;
List.map ~f:basic_color_to_int [Blue;Red];;
#part 2
let color_by_number number text =
sprintf "\027[38;5;%dm%s\027[0m" number text;;
let blue = color_by_number (basic_color_to_int Blue) "Blue";;
(* printf "Hello %s World!\n" blue*) ();;
#part 3
type weight = Regular | Bold
type color =
| Basic of basic_color * weight (* basic colors, regular and bold *)
| RGB of int * int * int (* 6x6x6 color cube *)
| Gray of int (* 24 grayscale levels *)
;;
[RGB (250,70,70); Basic (Green, Regular)];;
#part 4
let color_to_int = function
| Basic (basic_color,weight) ->
let base = match weight with Bold -> 8 | Regular -> 0 in
base + basic_color_to_int basic_color
| RGB (r,g,b) -> 16 + b + g * 6 + r * 36
| Gray i -> 232 + i ;;
#part 5
let color_print color s =
printf "%s\n" (color_by_number (color_to_int color) s);;
(* color_print (Basic (Red,Bold)) "A bold red!"*) ();;
(* color_print (Gray 4) "A muted gray..." *) ();;
#part 6
let three = `Int 3;;
let four = `Float 4.;;
let nan = `Not_a_number;;
[three; four; nan];;
#part 7
let five = `Int "five";;
[three; four; five];;
#part 8
let is_positive = function
| `Int x -> x > 0
| `Float x -> x > 0.
;;
#part 9
let exact = List.filter ~f:is_positive [three;four];;
#part 10
let is_positive = function
| `Int x -> Ok (x > 0)
| `Float x -> Ok (x > 0.)
| `Not_a_number -> Error "not a number";;
List.filter [three; four] ~f:(fun x ->
match is_positive x with Error _ -> false | Ok b -> b);;
#part 11
type extended_color =
| Basic of basic_color * weight (* basic colors, regular and bold *)
| RGB of int * int * int (* 6x6x6 color space *)
| Gray of int (* 24 grayscale levels *)
| RGBA of int * int * int * int (* 6x6x6x6 color space *)
;;
#part 12
let extended_color_to_int = function
| RGBA (r,g,b,a) -> 256 + a + b * 6 + g * 36 + r * 216
| (Basic _ | RGB _ | Gray _) as color -> color_to_int color
;;
#part 13
let basic_color_to_int = function
| `Black -> 0 | `Red -> 1 | `Green -> 2 | `Yellow -> 3
| `Blue -> 4 | `Magenta -> 5 | `Cyan -> 6 | `White -> 7
let color_to_int = function
| `Basic (basic_color,weight) ->
let base = match weight with `Bold -> 8 | `Regular -> 0 in
base + basic_color_to_int basic_color
| `RGB (r,g,b) -> 16 + b + g * 6 + r * 36
| `Gray i -> 232 + i
;;
#part 14
let extended_color_to_int = function
| `RGBA (r,g,b,a) -> 256 + a + b * 6 + g * 36 + r * 216
| (`Basic _ | `RGB _ | `Gray _) as color -> color_to_int color
;;
#part 15
let extended_color_to_int = function
| `RGBA (r,g,b,a) -> 256 + a + b * 6 + g * 36 + r * 216
| color -> color_to_int color
;;
#part 16
let is_positive_permissive = function
| `Int x -> Ok (x > 0)
| `Float x -> Ok (x > 0.)
| _ -> Error "Unknown number type"
;;
is_positive_permissive (`Int 0);;
is_positive_permissive (`Ratio (3,4));;
#part 17
is_positive_permissive (`Floot 3.5);;
#part 18
#part 19
#part 20
#part 21
#part 22
#part 23
#part 24
#part 25
#part 26
#part 27
#part 28
#part 29
#part 30
#part 31
#part 32
#part 33
#part 34
#part 35
#part 36
#part 37
#part 38
#part 39
#part 40
#part 41
#part 42
#part 43
#part 44
#part 45
#part 46
#part 47
#part 48
#part 49
#part 50
================================================
FILE: code/variants/variant.syntax
================================================
type =
| [ of [* ]... ]
| [ of [* ]... ]
| ...
================================================
FILE: code/variants-termcol/build.sh
================================================
corebuild terminal_color.native
================================================
FILE: code/variants-termcol/terminal_color.ml
================================================
open Core.Std
type basic_color =
[ `Black | `Blue | `Cyan | `Green
| `Magenta | `Red | `White | `Yellow ]
type color =
[ `Basic of basic_color * [ `Bold | `Regular ]
| `Gray of int
| `RGB of int * int * int ]
type extended_color =
[ color
| `RGBA of int * int * int * int ]
let basic_color_to_int = function
| `Black -> 0 | `Red -> 1 | `Green -> 2 | `Yellow -> 3
| `Blue -> 4 | `Magenta -> 5 | `Cyan -> 6 | `White -> 7
let color_to_int = function
| `Basic (basic_color,weight) ->
let base = match weight with `Bold -> 8 | `Regular -> 0 in
base + basic_color_to_int basic_color
| `RGB (r,g,b) -> 16 + b + g * 6 + r * 36
| `Gray i -> 232 + i
let extended_color_to_int = function
| `RGBA (r,g,b,a) -> 256 + a + b * 6 + g * 36 + r * 216
| `Grey x -> 2000 + x
| (`Basic _ | `RGB _ | `Gray _) as color -> color_to_int color
================================================
FILE: code/variants-termcol/terminal_color.mli
================================================
open Core.Std
type basic_color =
[ `Black | `Blue | `Cyan | `Green
| `Magenta | `Red | `White | `Yellow ]
type color =
[ `Basic of basic_color * [ `Bold | `Regular ]
| `Gray of int
| `RGB of int * int * int ]
type extended_color =
[ color
| `RGBA of int * int * int * int ]
val color_to_int : color -> int
val extended_color_to_int : extended_color -> int
================================================
FILE: code/variants-termcol-annotated/build.errsh
================================================
corebuild terminal_color.native
================================================
FILE: code/variants-termcol-annotated/terminal_color.ml
================================================
open Core.Std
type basic_color =
[ `Black | `Blue | `Cyan | `Green
| `Magenta | `Red | `White | `Yellow ]
type color =
[ `Basic of basic_color * [ `Bold | `Regular ]
| `Gray of int
| `RGB of int * int * int ]
type extended_color =
[ color
| `RGBA of int * int * int * int ]
let basic_color_to_int = function
| `Black -> 0 | `Red -> 1 | `Green -> 2 | `Yellow -> 3
| `Blue -> 4 | `Magenta -> 5 | `Cyan -> 6 | `White -> 7
let color_to_int = function
| `Basic (basic_color,weight) ->
let base = match weight with `Bold -> 8 | `Regular -> 0 in
base + basic_color_to_int basic_color
| `RGB (r,g,b) -> 16 + b + g * 6 + r * 36
| `Gray i -> 232 + i
(* part 1 *)
let extended_color_to_int : extended_color -> int = function
| `RGBA (r,g,b,a) -> 256 + a + b * 6 + g * 36 + r * 216
| `Grey x -> 2000 + x
| (`Basic _ | `RGB _ | `Gray _) as color -> color_to_int color
================================================
FILE: code/variants-termcol-annotated/terminal_color.mli
================================================
open Core.Std
type basic_color =
[ `Black | `Blue | `Cyan | `Green
| `Magenta | `Red | `White | `Yellow ]
type color =
[ `Basic of basic_color * [ `Bold | `Regular ]
| `Gray of int
| `RGB of int * int * int ]
type extended_color =
[ color
| `RGBA of int * int * int * int ]
val color_to_int : color -> int
val extended_color_to_int : extended_color -> int
================================================
FILE: code/variants-termcol-fixed/build.sh
================================================
corebuild terminal_color.native
================================================
FILE: code/variants-termcol-fixed/terminal_color.ml
================================================
open Core.Std
type basic_color =
[ `Black | `Blue | `Cyan | `Green
| `Magenta | `Red | `White | `Yellow ]
type color =
[ `Basic of basic_color * [ `Bold | `Regular ]
| `Gray of int
| `RGB of int * int * int ]
type extended_color =
[ color
| `RGBA of int * int * int * int ]
let basic_color_to_int = function
| `Black -> 0 | `Red -> 1 | `Green -> 2 | `Yellow -> 3
| `Blue -> 4 | `Magenta -> 5 | `Cyan -> 6 | `White -> 7
let color_to_int = function
| `Basic (basic_color,weight) ->
let base = match weight with `Bold -> 8 | `Regular -> 0 in
base + basic_color_to_int basic_color
| `RGB (r,g,b) -> 16 + b + g * 6 + r * 36
| `Gray i -> 232 + i
(* part 1 *)
let extended_color_to_int : extended_color -> int = function
| `RGBA (r,g,b,a) -> 256 + a + b * 6 + g * 36 + r * 216
| #color as color -> color_to_int color
================================================
FILE: code/variants-termcol-fixed/terminal_color.mli
================================================
open Core.Std
type basic_color =
[ `Black | `Blue | `Cyan | `Green
| `Magenta | `Red | `White | `Yellow ]
type color =
[ `Basic of basic_color * [ `Bold | `Regular ]
| `Gray of int
| `RGB of int * int * int ]
type extended_color =
[ color
| `RGBA of int * int * int * int ]
val color_to_int : color -> int
val extended_color_to_int : extended_color -> int