├── .merlin ├── .ocamlinit ├── .travis.yml ├── LICENCE ├── META ├── Makefile ├── README.md ├── examples ├── .merlin ├── buf.ml ├── counter.ml ├── cq.ml ├── cq.mltop ├── cqstub.c ├── hanoi.ml ├── hashtable.ml ├── putget.ml ├── putget.mltop ├── putgetstub.c ├── q.ml ├── stdio.ml ├── stdio.mltop ├── stdiostub.c ├── stk.ml └── waterjug.ml ├── qcstm.opam └── src ├── qCSTM.ml └── qCSTM.odocl /.merlin: -------------------------------------------------------------------------------- 1 | # source code paths 2 | S src examples 3 | 4 | # build path 5 | B _build/src 6 | 7 | # package path 8 | PKG ctypes ctypes.foreign qcheck ppx_deriving.show 9 | -------------------------------------------------------------------------------- /.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "_build/src";; 2 | #use "topfind";; 3 | #require "qcheck";; 4 | #require "ctypes";; 5 | #require "ctypes.foreign";; 6 | open QCheck;; 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | - OCAML_VERSION=4.07 7 | os: 8 | - linux 9 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | BSD 2-Clause License 2 | 3 | Copyright (c) 2019, Jan Midtgaard 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /META: -------------------------------------------------------------------------------- 1 | version = "0.1.1" 2 | description = "A simple state-machine framework for OCaml based on QCheck" 3 | requires = "" 4 | archive(byte) = "qCSTM.cma" 5 | archive(native) = "qCSTM.cmxa" 6 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ocamlbuild -use-ocamlfind -package qcheck src/qCSTM.cma 3 | ocamlbuild -use-ocamlfind -package qcheck src/qCSTM.cmxa 4 | 5 | install: all 6 | ocamlfind install qcstm META _build/src/qCSTM.cmi _build/src/qCSTM.cma _build/src/qCSTM.cmxa _build/src/qCSTM.a _build/src/qCSTM.cmo _build/src/qCSTM.cmx _build/src/qCSTM.o 7 | 8 | uninstall: 9 | ocamlfind remove qcstm 10 | 11 | doc: 12 | ocamlbuild -use-ocamlfind -package qcheck -docflags -d,doc src/qCSTM.docdir/index.html 13 | 14 | examples: queue counter waterjug stk hashtable buf putget stdio cq 15 | 16 | queue: 17 | ocamlbuild -use-ocamlfind -package qcheck,qcstm,ppx_deriving.show examples/q.cma examples/q.native 18 | 19 | counter: 20 | ocamlbuild -use-ocamlfind -package qcheck,qcstm,ppx_deriving.show examples/counter.cma examples/counter.native 21 | 22 | waterjug: 23 | ocamlbuild -use-ocamlfind -package qcheck,qcstm,ppx_deriving.show examples/waterjug.cma examples/waterjug.native 24 | 25 | stk: 26 | ocamlbuild -use-ocamlfind -package qcheck,qcstm,ppx_deriving.show examples/stk.cma examples/stk.native 27 | 28 | hashtable: 29 | ocamlbuild -use-ocamlfind -package qcheck,qcstm,ppx_deriving.show examples/hashtable.cma examples/hashtable.native 30 | 31 | buf: 32 | ocamlbuild -use-ocamlfind -package qcheck,qcstm,ppx_deriving.show examples/buf.cma examples/buf.native 33 | 34 | hanoi: 35 | ocamlbuild -use-ocamlfind -package qcheck,qcstm,ppx_deriving.show examples/hanoi.cma examples/hanoi.native 36 | 37 | putget: putgetstub.so 38 | ocamlbuild -use-ocamlfind -tag thread -package ctypes,ctypes.foreign,qcheck,qcstm,ppx_deriving.show examples/putget.native 39 | 40 | putgetstub.so: examples/putgetstub.c 41 | if [[ ! -d _build ]]; then mkdir _build; fi 42 | if [[ ! -d _build/examples ]]; then mkdir _build/examples; fi 43 | gcc -shared -o _build/examples/putgetstub.so -fPIC examples/putgetstub.c 44 | 45 | stdio: stdiostub.o 46 | ocamlbuild -use-ocamlfind -tag thread -package threads,ctypes,ctypes.foreign,qcheck,qcstm,ppx_deriving.show -lflags -custom,examples/stdiostub.o examples/stdio.cma examples/stdio.top 47 | ocamlbuild -use-ocamlfind -tag thread -package threads,ctypes,ctypes.foreign,qcheck,qcstm,ppx_deriving.show -lflags examples/stdiostub.o examples/stdio.native 48 | 49 | stdiostub.o: examples/stdiostub.c 50 | ocamlbuild examples/stdiostub.o 51 | 52 | cq: cqstub.o 53 | ocamlbuild -use-ocamlfind -tag thread -package threads,ctypes,ctypes.foreign,qcheck,qcstm,ppx_deriving.show -lflags -custom,examples/cqstub.o examples/cq.cma examples/cq.top 54 | ocamlbuild -use-ocamlfind -tag thread -package threads,ctypes,ctypes.foreign,qcheck,qcstm,ppx_deriving.show -lflags examples/cqstub.o examples/cq.native 55 | 56 | cqstub.o: examples/cqstub.c 57 | ocamlbuild examples/cqstub.o 58 | 59 | clean: 60 | ocamlbuild -clean 61 | rm -rf doc 62 | rm -f data.dat 63 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | QCSTM: A Simple State-Machine Framework for OCaml Based on QCheck 2 | ================================================================= 3 | 4 | [![Build Status](https://api.travis-ci.com/jmid/qcstm.svg?branch=master)](https://app.travis-ci.com/github/jmid/qcstm) 5 | 6 | This library implements a simple, typed state machine framework for 7 | property-based testing of imperative code. Tests are described by (a 8 | generator of) symbolic commands and two command interpreters over an 9 | abstract model and the system under test. 10 | 11 | The library requires a recent installation of both OCaml and the [QCheck](https://github.com/c-cube/qcheck) framework. 12 | 13 | State-machine frameworks for other languages include: 14 | - [Quviq QuickCheck](http://www.quviq.com/downloads/) for Erlang 15 | - [Proper](https://proper-testing.github.io/) for Erlang 16 | - [Triq](http://krestenkrab.github.io/triq/) for Erlang 17 | - [ScalaCheck](https://www.scalacheck.org/) for Scala 18 | - [Hedgehog](https://github.com/hedgehogqa) for Haskell and R 19 | - [quickcheck-state-machine](https://github.com/advancedtelematic/quickcheck-state-machine) for Haskell 20 | - [fast-check](https://github.com/dubzzz/fast-check) for JavaScript/TypeScript 21 | - [Lua-QuickCheck](https://github.com/luc-tielen/lua-quickcheck) for Lua 22 | - [RapidCheck](https://github.com/emil-e/rapidcheck) for C++ 23 | - ... 24 | 25 | QCSTM takes inspiration from the commercial Erlang state machine 26 | framework from Quviq and from ScalaCheck's state machine framework. 27 | 28 | The library is formulated as an OCaml functor. As its argument, the 29 | functor expects a module specifying 3 types: 30 | 31 | - `cmd`: the type of commands 32 | - `state`: the type of model's state 33 | - `sut`: the type of the system under test 34 | 35 | In addition the user has to provide: 36 | 37 | - `arb_cmd`: a generator of commands. It accepts a state parameter to enable state-dependent command generation. 38 | - `init_state` and `next_state`: specifies the initial state and the (single-step) state transition function 39 | of the model. 40 | - `run_cmd`: interprets a command over the system under test and returns a Boolean, indicating whether the 41 | execution went well, and whether any returned value agrees with the model's result. 42 | - `init_sut` and `cleanup`: specificies how to initialize and clean up after the system under test. 43 | - `precond`: specifies preconditions for each command. This is useful, e.g., to prevent the shrinker from 44 | breaking invariants when minimizing counterexamples. 45 | 46 | In return, the framework provides a generator of `cmd` lists (incl. a shrinker) 47 | as well as an agreement test between the model and system under test. 48 | 49 | 50 | Installation 51 | ------------ 52 | 53 | With `opam` this should be as simple as `opam install qcstm`. 54 | 55 | You can also install from source assuming you have `ocamlbuild`, 56 | `ocamlfind` and a not-too-ancient `qcheck` installed, by issuing: 57 | ``` 58 | make 59 | make install 60 | ``` 61 | 62 | To uninstall with `opam` just run `opam remove qcstm`. 63 | To uninstall from a source installation run `make uninstall` 64 | from the souce directory. 65 | 66 | 67 | An example 68 | ---------- 69 | 70 | Consider the following example (available in examples/counter.ml) that 71 | tests an `int ref` against a model consisting of a single `int`: 72 | 73 | ```ocaml 74 | open QCheck 75 | 76 | module CConf = 77 | struct 78 | type cmd = 79 | | Incr 80 | | Decr 81 | | Set of int 82 | | Deref [@@deriving show { with_path = false }] 83 | type state = int 84 | type sut = int ref 85 | 86 | let arb_cmd _ = 87 | let int_gen = Gen.oneof [Gen.int; Gen.nat] in 88 | QCheck.make ~print:show_cmd 89 | (Gen.oneof [Gen.return Incr; 90 | Gen.return Decr; 91 | Gen.map (fun i -> Set i) int_gen; 92 | Gen.return Deref]) 93 | 94 | let init_state = 0 95 | let init_sut () = ref 0 96 | let cleanup _ = () 97 | 98 | let next_state c s = match c with 99 | | Incr -> s+1 100 | | Decr -> s-1 101 | | Set i -> if i<>1213 then i else s (* an artificial fault *) 102 | | Deref -> s 103 | 104 | let run_cmd c s r = match c with 105 | | Incr -> (incr r; true) 106 | | Decr -> (decr r; true) 107 | | Set i -> (r := i; true) 108 | | Deref -> !r = s 109 | 110 | let precond _ _ = true 111 | end 112 | module CT = QCSTM.Make(CConf) 113 | ;; 114 | QCheck_runner.run_tests ~verbose:true [CT.agree_test ~count:10_000 ~name:"ref-model agreement"] 115 | ``` 116 | 117 | Here we provide a type of four different kinds of commands as well as 118 | a generator of these. `init_state` and `init_sut` specifies the 119 | initial states of both the model and the system under test. 120 | 121 | `next_state` and `run_cmd` interpret the four different commands over 122 | the model and the system under test, respectively. Since we can only 123 | observe references through a dereferencing operation, this is the only 124 | operation comparing the outputs from the two. 125 | 126 | To test whether the testsuite works as expected, we inject a bug in 127 | the model that ignores setting the reference when the argument is 128 | 1213. 129 | 130 | Finally we can compile the state machine model and run the 131 | tests. Depending on the underlying random number generator, this may 132 | or may not catch the model's bug in a given run: 133 | 134 | 135 | ``` 136 | $ make counter 137 | ocamlbuild -use-ocamlfind -package qcheck,qCSTM,ppx_deriving.show examples/counter.cma examples/counter.native 138 | Finished, 8 targets (3 cached) in 00:00:00. 139 | $ ./counter.native 140 | random seed: 272260055 141 | generated error fail pass / total time test name 142 | [✓] 10000 0 0 10000 / 10000 1.0s ref-model agreement 143 | ================================================================================ 144 | success (ran 1 tests) 145 | $ ./counter.native 146 | random seed: 36511368 147 | generated error fail pass / total time test name 148 | [✗] 2032 0 1 2031 / 10000 1.2s ref-model agreement 149 | 150 | --- Failure -------------------------------------------------------------------- 151 | 152 | Test ref-model agreement failed (14 shrink steps): 153 | 154 | [(Set 1213); Deref] 155 | ================================================================================ 156 | failure (1 tests failed, 0 tests errored, ran 1 tests) 157 | ``` 158 | 159 | 160 | A number of additional examples are provided in the [examples](examples/) 161 | directory, including examples of testing OCaml code: 162 | 163 | - [examples/buf.ml](examples/buf.ml): tests the standard library `Buffer` module 164 | - [examples/counter.ml](examples/counter.ml): the above `int ref` example 165 | - [examples/hashtable.ml](examples/hashtable.ml): tests the standard library `Hashtbl` module 166 | - [examples/q.ml](examples/q.ml): tests the standard library `Queue` module 167 | - [examples/stk.ml](examples/stk.ml): tests the standard library `Stack` module 168 | 169 | There are also examples of testing C code: 170 | 171 | - [examples/putget.ml](examples/putget.ml): tests two C functions, from [Hughes: Certifying your car with Erlang](https://vimeo.com/68331689) 172 | - [examples/cq.ml](examples/cq.ml): tests a circular buffer in C, from [Hughes: Testing the Hard Stuff and Staying Sane](https://www.youtube.com/watch?v=zi0rHwfiX1Q) 173 | - [examples/stdio.ml](examples/stdio.ml): tests a few stdio library operations in C, also from [Hughes: Certifying your car with Erlang](https://vimeo.com/68331689) 174 | 175 | Finally there are a few puzzle examples where the command generator is (mis)used to search for a solution: 176 | 177 | - [examples/hanoi.ml](examples/hanoi.ml): Towers of Hanoi example inspired by [this Hypothesis issue](https://github.com/HypothesisWorks/hypothesis/issues/1857) 178 | - [examples/waterjug.ml](examples/waterjug.ml): Die Hard water jug puzzle adapted from [this post](https://hypothesis.works/articles/how-not-to-die-hard-with-hypothesis/) and [this post](http://clrnd.com.ar/posts/2017-04-21-the-water-jug-problem-in-hedgehog.html) 179 | -------------------------------------------------------------------------------- /examples/.merlin: -------------------------------------------------------------------------------- 1 | # package path 2 | PKG ctypes ctypes.foreign qcheck qcstm ppx_deriving.show 3 | -------------------------------------------------------------------------------- /examples/buf.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | 3 | module BConf = 4 | struct 5 | type state = char list (* in reverse *) 6 | type sut = Buffer.t 7 | type cmd = 8 | | Contents 9 | (* To_bytes | Sub | Blit *) 10 | | Nth of int 11 | | Length 12 | | Clear 13 | | Reset 14 | | Add_char of char 15 | (* Add_utf8_uchar | Add_utf_16le_uchar | Add_utf_16be_uchar *) 16 | | Add_string of string 17 | (*| Add_bytes of bytes*) 18 | | Truncate of int 19 | [@@deriving show { with_path = false }] 20 | 21 | let arb_cmd s = 22 | QCheck.make ~print:show_cmd 23 | (Gen.oneof [Gen.return Contents; 24 | Gen.map (fun i -> Nth i) Gen.small_nat; 25 | Gen.return Length; 26 | Gen.return Clear; 27 | Gen.return Reset; 28 | Gen.map (fun c -> Add_char c) Gen.char; 29 | Gen.map (fun s -> Add_string s) (Gen.string); 30 | Gen.map (fun i -> Truncate i) (let len = List.length s in 31 | if len = 0 32 | then Gen.return 0 33 | else Gen.int_bound (len - 1)); 34 | ]) 35 | 36 | let init_state = [] 37 | 38 | let rev_explode s = 39 | let chars = ref [] in 40 | String.iter (fun c -> chars := c::!chars) s; 41 | !chars 42 | 43 | let explode s = List.rev (rev_explode s) 44 | 45 | let next_state c s = match c with 46 | | Contents -> s 47 | | Nth _ -> s 48 | | Length -> s 49 | | Clear -> [] 50 | | Reset -> [] 51 | | Add_char ch -> ch::s 52 | | Add_string str -> (rev_explode str)@s (*s@(explode str)*) 53 | | Truncate i -> 54 | let rec trunc buf n = match buf,n with 55 | | [],0 -> [] 56 | | [],_ -> raise (Invalid_argument "truncate") 57 | | c::cs,0 -> [] 58 | | c::cs,_ -> c::trunc cs (n-1) in 59 | List.rev (trunc (List.rev s) i) 60 | 61 | let init_sut () = Buffer.create 16 62 | let cleanup b = Buffer.reset b 63 | let run_cmd c s b = match c with 64 | | Contents -> explode (Buffer.contents b) = List.rev s 65 | | Nth i -> 66 | let r = try Some (Buffer.nth b i) 67 | with Invalid_argument _ -> None in 68 | let r' = try Some (List.nth (List.rev s) i) 69 | with Failure _ -> None in 70 | r = r' 71 | | Length -> Buffer.length b = List.length s 72 | | Clear -> Buffer.clear b; true 73 | | Reset -> Buffer.reset b; true 74 | | Add_char ch -> Buffer.add_char b ch; true 75 | | Add_string str -> Buffer.add_string b str; true 76 | | Truncate i -> 77 | try (Buffer.truncate b i; true) 78 | with Invalid_argument _ -> (i < 0 || i > List.length s) 79 | 80 | let precond c s = match c with 81 | | Truncate i -> i >= 0 && i <= List.length s 82 | | _ -> true 83 | end 84 | 85 | module BT = QCSTM.Make(BConf) 86 | ;; 87 | QCheck_runner.run_tests ~verbose:true 88 | [BT.consistency_test ~count:1000 ~name:"buffer-consistent"; 89 | BT.agree_test ~count:10_000 ~name:"buffer-model"] 90 | -------------------------------------------------------------------------------- /examples/counter.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | 3 | module CConf = 4 | struct 5 | type cmd = 6 | | Incr 7 | | Decr 8 | | Set of int 9 | | Deref [@@deriving show { with_path = false }] 10 | type state = int 11 | type sut = int ref 12 | 13 | let arb_cmd _ = 14 | let int_gen = Gen.oneof [Gen.int; Gen.nat] in 15 | QCheck.make ~print:show_cmd 16 | (Gen.oneof [Gen.return Incr; 17 | Gen.return Decr; 18 | Gen.map (fun i -> Set i) int_gen; 19 | Gen.return Deref]) 20 | 21 | let init_state = 0 22 | let init_sut () = ref 0 23 | let cleanup _ = () 24 | 25 | let next_state c s = match c with 26 | | Incr -> s+1 27 | | Decr -> s-1 28 | | Set i -> if i<>1213 then i else s (* an artificial fault *) 29 | | Deref -> s 30 | 31 | let run_cmd c s r = match c with 32 | | Incr -> (incr r; true) 33 | | Decr -> (decr r; true) 34 | | Set i -> (r := i; true) 35 | | Deref -> !r = s 36 | 37 | let precond _ _ = true 38 | end 39 | module CT = QCSTM.Make(CConf) 40 | ;; 41 | QCheck_runner.run_tests ~verbose:true [CT.agree_test ~count:10_000 ~name:"ref-model agreement"] 42 | -------------------------------------------------------------------------------- /examples/cq.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open Ctypes 3 | open PosixTypes 4 | open Foreign 5 | 6 | type queue = unit ptr 7 | let queue : queue typ = ptr void 8 | 9 | let alloc = foreign "new" (int @-> returning queue) (* Queue *new(int n) *) 10 | let put = foreign "put" (queue @-> int @-> returning void) (* void put(Queue *q, int n) *) 11 | let get = foreign "get" (queue @-> returning int) (* int get(Queue *q) *) 12 | let size = foreign "size" (queue @-> returning int) (* int size(Queue *q) *) 13 | 14 | module CqConf = 15 | struct 16 | type state = Undef | Def of { size: int; contents : int list } 17 | type sut = queue option ref 18 | type cmd = 19 | | New of int 20 | | Put of int 21 | | Get 22 | | Size [@@deriving show { with_path = false }] 23 | 24 | (* gen_cmd : state -> cmd Gen.t *) 25 | let gen_cmd s = 26 | let int_gen = Gen.oneof [(*Gen.map Int32.to_int int32.gen;*) Gen.small_nat] in 27 | match s with 28 | | Undef -> Gen.map (fun i -> New (i+1)) int_gen 29 | | Def s -> 30 | Gen.oneof 31 | ((if s.contents = [] then [] else [Gen.return Get]) 32 | @ (if List.length s.contents < s.size 33 | then [Gen.map (fun i -> Put i) int_gen] 34 | else []) 35 | @ [ Gen.return Size; ]) 36 | 37 | let arb_cmd s = 38 | let shrink c = match c with 39 | | New i -> Iter.map (fun i' -> New i') (Shrink.int i) 40 | | Put i -> Iter.map (fun i' -> Put i') (Shrink.int i) 41 | | Get 42 | | Size -> Iter.empty in 43 | QCheck.make ~print:show_cmd ~shrink:shrink (gen_cmd s) 44 | 45 | let init_state = Undef 46 | let next_state c s = match c with 47 | | New n -> Def { size = n; contents = [] } 48 | | Put n -> (match s with 49 | | Undef -> failwith "no model to put" 50 | | Def s -> Def { s with contents = s.contents@[n] }) 51 | | Get -> (match s with 52 | | Undef -> failwith "no model to get" 53 | | Def s -> Def { s with contents = List.tl s.contents }) 54 | | Size -> s 55 | 56 | let init_sut () = ref None 57 | let cleanup _ = () 58 | let run_cmd c s q = match c with 59 | | New n -> q := Some (alloc n); true 60 | | Put n -> (match !q with 61 | | Some q -> put q n; true 62 | | None -> failwith "no queue to put") 63 | | Get -> (match !q with 64 | | Some q -> 65 | let i = get q in 66 | (match s with 67 | | Undef -> false 68 | | Def s -> i = List.hd s.contents) 69 | | None -> failwith "no queue to get") 70 | | Size -> (match !q with 71 | | Some q -> 72 | (match s with 73 | | Undef -> ignore (size q); false 74 | | Def s -> List.length s.contents = size q) 75 | | None -> failwith "no queue to size") 76 | 77 | let precond c s = match c with 78 | | New n -> s = Undef && n > 0 79 | | Put _ -> (match s with 80 | | Undef -> false 81 | | Def s -> List.length s.contents < s.size) 82 | | Get -> (match s with 83 | | Undef -> false 84 | | Def s -> s.contents <> []) 85 | | Size -> s <> Undef 86 | end 87 | 88 | module CqT = QCSTM.Make(CqConf) 89 | ;; 90 | QCheck_runner.run_tests ~verbose:true 91 | [CqT.consistency_test ~count:2000 ~name:"circular-queue consistency"; 92 | CqT.agree_test ~count:10_000 ~name:"circular-queue-model agreement"] 93 | -------------------------------------------------------------------------------- /examples/cq.mltop: -------------------------------------------------------------------------------- 1 | examples/cq 2 | -------------------------------------------------------------------------------- /examples/cqstub.c: -------------------------------------------------------------------------------- 1 | // Queue example from John Hughes 2 | // "Experiences with QuickCheck: Testing the Hard Stuff and Staying Sane" 3 | #include 4 | 5 | typedef struct queue 6 | { int *buf; 7 | int inp, outp, size; 8 | } Queue; 9 | 10 | Queue *new(int n) 11 | { int *buff = malloc((n+1) * sizeof(int)); //fix 12 | Queue q = {buff, 0, 0, n+1}; //fix 13 | Queue *qptr = malloc(sizeof(Queue)); 14 | *qptr = q; 15 | return qptr; } 16 | 17 | void put(Queue *q, int n) 18 | { q -> buf[q -> inp] = n; 19 | q -> inp = (q -> inp + 1) % q->size; } 20 | 21 | int get(Queue *q) 22 | { int ans = q -> buf[q -> outp]; 23 | q -> outp = (q -> outp + 1) % q->size; 24 | return ans; } 25 | 26 | int size(Queue *q) 27 | { return (q->inp - q->outp + q->size) % q->size; } //fix 28 | -------------------------------------------------------------------------------- /examples/hanoi.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | 3 | module HanoiConf = 4 | struct 5 | type peg = Peg1 | Peg2 | Peg3 [@@deriving show { with_path = false }] 6 | type cmd = Move of peg * peg [@@deriving show { with_path = false }] 7 | type state = { peg1: int list; 8 | peg2: int list; 9 | peg3: int list; } 10 | type sut = unit 11 | 12 | let contents s peg = match peg with 13 | | Peg1 -> s.peg1 14 | | Peg2 -> s.peg2 15 | | Peg3 -> s.peg3 16 | 17 | let pop src s = match src with 18 | | Peg1 -> List.hd s.peg1, { s with peg1 = List.tl s.peg1 } 19 | | Peg2 -> List.hd s.peg2, { s with peg2 = List.tl s.peg2 } 20 | | Peg3 -> List.hd s.peg3, { s with peg3 = List.tl s.peg3 } 21 | 22 | let push dst s v = match dst with 23 | | Peg1 -> { s with peg1 = v::s.peg1 } 24 | | Peg2 -> { s with peg2 = v::s.peg2 } 25 | | Peg3 -> { s with peg3 = v::s.peg3 } 26 | 27 | let precond (Move (src,dst)) s = 28 | src <> dst && 29 | match contents s src, contents s dst with 30 | | [], _ -> false 31 | | _, [] -> true 32 | | x::_, y::_ -> x 38 | List.fold_right (fun dst acc -> 39 | let m = Move(src,dst) in 40 | if precond m s then m::acc else acc) pegs) pegs [] in 41 | Gen.oneofl moves 42 | 43 | let arb_cmd s = QCheck.make ~print:show_cmd (gen_cmd s) 44 | 45 | let init_state = { peg1 = [1;2;3;4]; 46 | peg2 = []; 47 | peg3 = []; } 48 | 49 | let next_state (Move (src,dst)) s = 50 | if src = dst 51 | then failwith ("illegal move: " ^ show_cmd (Move (src,dst))) 52 | else 53 | let hd,s = pop src s in 54 | push dst s hd 55 | 56 | let init_sut _ = () 57 | let cleanup _ = () 58 | 59 | let run_cmd c s sut = (* "we never hit a state with first two pegs empty" *) 60 | let next = next_state c s in 61 | not (next.peg1 = [] && next.peg2 = []) 62 | end 63 | 64 | module HT = QCSTM.Make(HanoiConf) 65 | ;; 66 | QCheck_runner.run_tests ~verbose:true [HT.agree_test ~count:100 ~name:"towers of Hanoi"] 67 | -------------------------------------------------------------------------------- /examples/hashtable.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | 3 | module HConf = 4 | struct 5 | type state = (string * int) list 6 | type sut = (string, int) Hashtbl.t 7 | type cmd = 8 | | Clear 9 | | Add of string * int 10 | | Remove of string 11 | | Find of string 12 | | Find_opt of string 13 | | Find_all of string 14 | | Replace of string * int 15 | | Mem of string 16 | | Length [@@deriving show { with_path = false }] 17 | 18 | (* gen_cmd : state -> command Gen.t *) 19 | let gen_cmd s = 20 | let int_gen = Gen.nat in 21 | let str_gen = 22 | if s=[] 23 | then Gen.oneof [Gen.small_string; 24 | Gen.string] 25 | else 26 | let keys = List.map fst s in 27 | Gen.oneof [Gen.oneofl keys; 28 | Gen.small_string; 29 | Gen.string] in 30 | Gen.oneof 31 | [ Gen.return Clear; 32 | Gen.map2 (fun k v -> Add (k,v)) str_gen int_gen; 33 | Gen.map (fun k -> Remove k) str_gen; 34 | Gen.map (fun k -> Find k) str_gen; 35 | Gen.map (fun k -> Find_opt k) str_gen; 36 | Gen.map (fun k -> Find_all k) str_gen; 37 | Gen.map2 (fun k v -> Replace (k,v)) str_gen int_gen; 38 | Gen.map (fun k -> Mem k) str_gen; 39 | Gen.return Length; ] 40 | 41 | let shrink c = let open Iter in match c with 42 | | Clear -> Iter.empty 43 | | Add (k,v) -> 44 | (Iter.map (fun k' -> Add (k',v)) (Shrink.string k)) <+> 45 | (Iter.map (fun v' -> Add (k,v')) (Shrink.int v)) 46 | | Remove k -> Iter.map (fun k' -> Remove k') (Shrink.string k) 47 | | Find k -> Iter.map (fun k' -> Find k') (Shrink.string k) 48 | | Find_opt k -> Iter.map (fun k' -> Find_opt k') (Shrink.string k) 49 | | Find_all k -> Iter.map (fun k' -> Find_all k') (Shrink.string k) 50 | | Replace (k,v) -> 51 | (Iter.map (fun k' -> Replace (k',v)) (Shrink.string k)) <+> 52 | (Iter.map (fun v' -> Replace (k,v')) (Shrink.int v)) 53 | | Mem k -> Iter.map (fun k' -> Mem k') (Shrink.string k) 54 | | Length -> Iter.empty 55 | 56 | let arb_cmd s = QCheck.make ~print:show_cmd ~shrink:shrink (gen_cmd s) 57 | 58 | let init_state = [] 59 | let next_state c s = match c with 60 | | Clear -> [] 61 | | Add (k,v) -> (k,v)::s 62 | | Remove k -> List.remove_assoc k s 63 | | Replace (k,v) -> (k,v)::(List.remove_assoc k s) 64 | | Find _ 65 | | Find_opt _ 66 | | Find_all _ 67 | | Mem _ 68 | | Length -> s 69 | 70 | let init_sut () = Hashtbl.create ~random:false 42 71 | let cleanup _ = () 72 | let run_cmd c s h = match c with 73 | | Clear -> Hashtbl.clear h; true 74 | | Add (k,v) -> Hashtbl.add h k v; true 75 | | Remove k -> Hashtbl.remove h k; true 76 | | Find k -> List.assoc_opt k s 77 | = (try Some (Hashtbl.find h k) 78 | with Not_found -> None) 79 | | Find_opt k -> List.assoc_opt k s = Hashtbl.find_opt h k 80 | | Find_all k -> 81 | (* List.map snd (List.find_all (fun p -> fst p = k) s) 82 | = Hashtbl.find_all h k *) 83 | let rec find_all h = match h with 84 | | [] -> [] 85 | | (k',v')::h' -> 86 | if k = k' (*&& k<>"a"*) (* an arbitrary, injected bug *) 87 | then v'::find_all h' 88 | else find_all h' in 89 | find_all s = Hashtbl.find_all h k 90 | | Replace (k,v) -> Hashtbl.replace h k v; true 91 | | Mem k -> List.mem_assoc k s = Hashtbl.mem h k 92 | | Length -> List.length s = Hashtbl.length h 93 | 94 | let precond c s = true 95 | end 96 | module HT = QCSTM.Make(HConf) 97 | ;; 98 | QCheck_runner.run_tests ~verbose:true 99 | [HT.agree_test ~count:10_000 ~name:"Hashtbl-model agreement"] 100 | -------------------------------------------------------------------------------- /examples/putget.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open Ctypes 3 | open Foreign 4 | 5 | module PGConf = 6 | struct 7 | type cmd = Put of int | Get [@@deriving show { with_path = false }] 8 | type state = int 9 | type sut = Dl.library * (int -> unit) * (unit -> int) 10 | 11 | let arb_cmd s = 12 | let int_gen = Gen.oneof [Gen.map Int32.to_int int32.gen; Gen.nat] in 13 | let shrink c = match c with 14 | | Put i -> Iter.map (fun i' -> Put i') (Shrink.int i) 15 | | Get -> Iter.empty in 16 | QCheck.make ~print:show_cmd ~shrink:shrink 17 | (Gen.oneof [Gen.map (fun i -> Put i) int_gen; Gen.return Get]) 18 | 19 | let init_state = 0 20 | let next_state c s = match c with 21 | | Put i -> i 22 | | Get -> s 23 | 24 | let init_sut () = 25 | let stub = 26 | Dl.dlopen ~filename:"_build/examples/putgetstub.so" ~flags:[Dl.RTLD_LOCAL;Dl.RTLD_NOW;] (*[Dl.RTLD_LAZY; Dl.RTLD_GLOBAL]*) in 27 | let put = foreign ~from:stub "put" (int @-> returning void) in 28 | let get = foreign ~from:stub "get" (void @-> returning int) in 29 | (stub,put,get) 30 | 31 | let cleanup (stub,_,_) = Dl.dlclose stub 32 | 33 | let run_cmd c s (_,put,get) = match c with 34 | | Put i -> (put i; true) 35 | | Get -> (get () = s) 36 | 37 | let precond _ _ = true 38 | end 39 | module PGtest = QCSTM.Make(PGConf) 40 | ;; 41 | QCheck_runner.run_tests ~verbose:true 42 | [PGtest.agree_test ~count:10_000 ~name:"put/get-model agreement"] 43 | -------------------------------------------------------------------------------- /examples/putget.mltop: -------------------------------------------------------------------------------- 1 | src/QCSTM 2 | examples/putget 3 | -------------------------------------------------------------------------------- /examples/putgetstub.c: -------------------------------------------------------------------------------- 1 | // Simple example from John Hughes: Certifying your car with Erlang 2 | int n = 0; 3 | 4 | void put(int m) 5 | { if (n != 5538) n = m; } // an arbitrary injected bug 6 | 7 | int get() 8 | { return n; } 9 | -------------------------------------------------------------------------------- /examples/q.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | 3 | module QConf = 4 | struct 5 | type cmd = 6 | | Pop (* may throw exception *) 7 | | Top (* may throw exception *) 8 | | Push of int 9 | | Clear 10 | | Is_empty [@@deriving show { with_path = false }] 11 | type state = int list 12 | type sut = int Queue.t 13 | 14 | let gen_cmd s = 15 | let int_gen = Gen.oneof [Gen.int; Gen.nat] in 16 | if s = [] 17 | then Gen.oneof (* don't generate pop/tops from empty *) 18 | [Gen.map (fun i -> Push i) int_gen; 19 | Gen.return Clear; 20 | Gen.return Is_empty] 21 | else Gen.oneof (* weight the below for fewer pushes? *) 22 | [Gen.return Pop; 23 | Gen.return Top; 24 | Gen.map (fun i -> Push i) int_gen; 25 | Gen.return Clear; 26 | Gen.return Is_empty] 27 | 28 | let arb_cmd s = 29 | let shrink c = match c with 30 | | Push i -> Iter.map (fun i' -> Push i') (Shrink.int i) 31 | | Pop 32 | | Top 33 | | Clear 34 | | Is_empty -> Iter.empty in 35 | QCheck.make ~print:show_cmd ~shrink:shrink (gen_cmd s) 36 | 37 | let init_state = [] 38 | let next_state c s = match c with 39 | | Pop -> (match s with 40 | | [] -> failwith "tried to pop empty queue" 41 | | _::s' -> s') 42 | | Push i -> (* s@[i] *) 43 | if i<>135 then s@[i] else s (* an artificial fault in the model *) 44 | | Clear -> [] 45 | | Top -> s 46 | | Is_empty -> s 47 | 48 | 49 | let init_sut = Queue.create 50 | let cleanup _ = () 51 | let run_cmd c s q = match c with 52 | | Pop -> (try (Queue.pop q = List.hd s) with _ -> false) 53 | | Top -> (try (Queue.top q = List.hd s) with _ -> false) 54 | | Push n -> (Queue.push n q; true) 55 | | Clear -> (Queue.clear q; true) 56 | | Is_empty -> (Queue.is_empty q) = (s = []) 57 | 58 | let precond c s = match c with 59 | | Pop -> s<>[] 60 | | Top -> s<>[] 61 | | _ -> true 62 | end 63 | 64 | module QT = QCSTM.Make(QConf) 65 | ;; 66 | QCheck_runner.run_tests ~verbose:true [QT.agree_test ~count:10_000 ~name:"queue-model agreement"] 67 | -------------------------------------------------------------------------------- /examples/stdio.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | open Ctypes 3 | open PosixTypes 4 | open Foreign 5 | 6 | type stream = unit ptr 7 | let stream : stream typ = ptr void 8 | let stream_opt : stream option typ = ptr_opt void 9 | 10 | let seek_set = foreign "seek_set" (void @-> returning int) 11 | (* FILE *fopen(const char *path, const char *mode); *) 12 | let fopen = foreign "fopen" (string @-> string @-> returning stream_opt) 13 | (* int fseek(FILE *stream_pointer, long offset, int origin); *) 14 | let fseek = foreign "fseek" (stream @-> long @-> int @-> returning int) 15 | (* size_t fread (void * restrict ptr, size_t size, size_t nmemb, FILE * restrict stream) *) 16 | let fread = foreign "fread" (ptr void @-> size_t @-> size_t @-> stream @-> returning size_t) 17 | (* int fwrite ( const void * array, size_t size, size_t count, FILE * stream ); *) 18 | let fwrite = foreign "fwrite" (ptr void @-> size_t @-> size_t @-> stream @-> returning int) 19 | (* int fclose(FILE *file_pointer) *) 20 | let fclose = foreign "fclose" (stream @-> returning int) 21 | 22 | (* a couple of helpers, missing from the standard lib *) 23 | let rec make_list e len = if len=0 then [] else e::(make_list e (len-1)) 24 | let rec split_list n es = match n,es with 25 | | 0, _ -> [],es 26 | | _, [] -> raise (Failure "split_list: split point beyond length") 27 | | _, e::es -> let fst,snd = split_list (n-1) es in 28 | e::fst,snd 29 | 30 | (* a simpler fread version, accepting only a number *) 31 | let fread' n str = 32 | let buf = CArray.make char n in 33 | let m = fread (to_voidp (CArray.start buf)) (Unsigned.Size_t.of_int 1) (Unsigned.Size_t.of_int n) str in (*(Unsigned.Size_t.to_int m), (CArray.to_list buf) *) 34 | let res,_ = split_list (Unsigned.Size_t.to_int m) (CArray.to_list buf) in 35 | res (* return the content, representing the m read entries *) 36 | 37 | (* a simpler fwrite version, accepting only a list *) 38 | let fwrite' lst str = 39 | let arr = CArray.of_list char lst in 40 | let len = Unsigned.Size_t.of_int (List.length lst) in 41 | fwrite (to_voidp (CArray.start arr)) (Unsigned.Size_t.of_int 1) len str 42 | 43 | module StdioConf = (* Reference: http://pubs.opengroup.org/onlinepubs/9699919799/ *) 44 | struct 45 | type cmd = 46 | | Fopen of string * string 47 | | Fseek of int 48 | | Fread of int 49 | | Fwrite of char list 50 | | Fclose [@@deriving show { with_path = false }] 51 | type state = { status : strstatus; contents : char list; pos : int } 52 | and strstatus = Open | Closed | Writing | Reading 53 | type sut = stream option ref 54 | 55 | let arb_cmd s = 56 | let int_gen = Gen.oneof [(*Gen.map Int32.to_int int32.gen;*) Gen.small_nat] in 57 | let shrink c = match c with 58 | | Fopen (fn,flags) -> Iter.empty 59 | | Fread i -> Iter.map (fun i' -> Fread i') (Shrink.int i) 60 | | Fseek i -> Iter.map (fun i' -> Fseek i') (Shrink.int i) 61 | | Fwrite cs -> Iter.map (fun cs' -> Fwrite cs') (Shrink.list cs) 62 | | Fclose -> Iter.empty in 63 | QCheck.make ~print:show_cmd ~shrink:shrink 64 | (match s.status with 65 | | Closed -> Gen.return (Fopen ("data.dat","wb+")) 66 | | Open -> 67 | (Gen.oneof 68 | [Gen.map (fun i -> Fread i) int_gen; 69 | Gen.map (fun i -> Fseek i) int_gen; 70 | Gen.map (fun cs -> Fwrite cs) (Gen.list Gen.char); 71 | Gen.return Fclose; ]) 72 | | Reading -> 73 | (Gen.oneof 74 | [Gen.map (fun i -> Fread i) int_gen; 75 | Gen.map (fun i -> Fseek i) int_gen; 76 | Gen.return Fclose; ]) 77 | | Writing -> 78 | (Gen.oneof 79 | [Gen.map (fun i -> Fseek i) int_gen; 80 | Gen.map (fun cs -> Fwrite cs) (Gen.list Gen.char); 81 | Gen.return Fclose; ])) 82 | 83 | let init_state = { status = Closed; contents = []; pos = 0 } 84 | let next_state c s = match c with 85 | | Fopen (fn,fl) -> { init_state with status = Open } (* "wb+" truncates to 0 length *) 86 | | Fread i -> 87 | let read = min i (max 0 (List.length s.contents - s.pos)) in 88 | { s with pos = s.pos + read; status = Reading} (* advance reading position *) 89 | | Fseek i -> { s with pos = i; status = Open } 90 | | Fwrite cs -> 91 | (match cs with 92 | | [] -> s (* If size or nitems is 0, 93 | fwrite() shall return 0 and the state of the stream remains unchanged *) 94 | | _ -> 95 | let cs_len = List.length cs in 96 | let cont_len = List.length s.contents in 97 | let extended = 98 | if s.pos + List.length cs <= cont_len 99 | then s.contents 100 | else s.contents @ (make_list '\000' (s.pos + cs_len - cont_len)) in 101 | let pre,rest = split_list s.pos extended in 102 | let _mid,post = split_list cs_len rest in 103 | { status = Writing; 104 | contents = pre @ cs @ post; 105 | pos = s.pos + cs_len }) 106 | | Fclose -> { s with status = Closed } 107 | 108 | let init_sut () = ref None 109 | let cleanup sut = match !sut with 110 | | None -> () 111 | | Some str -> ignore (fclose str) 112 | let run_cmd c s sut = match c with 113 | | Fopen (fn,fl) -> let s = fopen fn fl in 114 | ((*Printf.printf "fopen returns %i\n%!" (Obj.obj (Obj.repr s));*) 115 | sut := s; s<>None) 116 | | Fread i -> 117 | (match !sut with 118 | | Some str -> 119 | let resbuf = fread' i str in 120 | if s.pos > List.length s.contents 121 | then resbuf = [] 122 | else (* s.pos <= List.length s.contents *) 123 | let _pre,rest = split_list s.pos s.contents in 124 | if i > List.length rest 125 | then resbuf = rest 126 | else (* i <= List.length rest *) 127 | let mid,_ = split_list i rest in 128 | mid = resbuf 129 | | None -> raise (Failure "no stream to read")) 130 | | Fseek i -> 131 | (match !sut with 132 | | Some str -> 133 | let s = fseek str (Signed.Long.of_int64 (Int64.of_int i)) (seek_set()) 134 | in s=0 135 | | None -> raise (Failure "no stream to seek")) 136 | | Fwrite cs -> (match !sut with 137 | | Some str -> let i = fwrite' cs str in i=(List.length cs) 138 | | None -> raise (Failure "no stream to write to")) 139 | | Fclose -> (match !sut with 140 | | Some str -> let i = fclose str in 141 | sut := None; i=0 142 | | None -> raise (Failure "no stream to close")) 143 | 144 | let precond c s = match c with 145 | | Fopen (_,_) -> s.status=Closed (* avoid reopen *) 146 | | Fread _ -> s.status<>Closed && s.status<>Writing 147 | | Fseek _ -> s.status<>Closed 148 | | Fwrite _ -> s.status<>Closed && s.status<>Reading 149 | | Fclose -> s.status<>Closed 150 | end 151 | module StdioT = QCSTM.Make(StdioConf) 152 | ;; 153 | QCheck_runner.run_tests ~verbose:true 154 | [StdioT.agree_test ~count:200 ~name:"stdio-model agreement"] 155 | -------------------------------------------------------------------------------- /examples/stdio.mltop: -------------------------------------------------------------------------------- 1 | examples/stdio 2 | -------------------------------------------------------------------------------- /examples/stdiostub.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int seek_set() 4 | { return SEEK_SET; } 5 | -------------------------------------------------------------------------------- /examples/stk.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | 3 | module StConf = 4 | struct 5 | type cmd = 6 | | Push of char 7 | | Pop 8 | | Top 9 | | Clear 10 | (* | Copy *) 11 | | Is_empty 12 | | Length 13 | (* | Iter f *) 14 | | Fold of (string -> char -> string) fun_ * string [@printer fun fmt (f,s) -> fprintf fmt "(%s, \"%s\")" (Fn.print f) (Print.string s)] 15 | [@@deriving show { with_path = false }] 16 | 17 | type state = char list 18 | type sut = char Stack.t 19 | 20 | (* gen_cmd : state -> cmd Gen.t *) 21 | let gen_cmd s = 22 | Gen.oneof ((if s = [] 23 | then [] 24 | else [Gen.return Pop; 25 | Gen.return Top]) 26 | @ 27 | [Gen.map (fun c -> Push c) Gen.char; 28 | Gen.return Clear; 29 | Gen.return Is_empty; 30 | Gen.return Length; 31 | Gen.map2 (fun f a -> Fold (f,a)) 32 | (fun2 Observable.string Observable.char small_string).gen 33 | Gen.small_string; 34 | ]) 35 | 36 | let shrink c = match c with 37 | | Fold (f,a) -> 38 | Iter.(map (fun f' -> Fold (f',a)) (Fn.shrink f) 39 | <+> map (fun a' -> Fold (f,a')) (Shrink.string a)) 40 | | _ -> Iter.empty 41 | 42 | let arb_cmd s = QCheck.make ~print:show_cmd ~shrink:shrink (gen_cmd s) 43 | 44 | let init_state = [] 45 | let next_state c s = match c with 46 | | Push e -> e::s 47 | | Pop -> List.tl s 48 | | Clear -> [] 49 | | Top 50 | | Is_empty 51 | | Length 52 | | Fold (_,_) -> s 53 | 54 | let init_sut = Stack.create 55 | let cleanup _ = () 56 | let run_cmd c s st = match c with 57 | | Push e -> Stack.push e st; true 58 | | Pop -> (try Stack.pop st = List.hd s with _ -> false) 59 | | Top -> (try Stack.top st = List.hd s with _ -> false) 60 | | Clear -> Stack.clear st; true 61 | | Is_empty -> (Stack.is_empty st) = (s = []) 62 | | Length -> (Stack.length st = List.length s) 63 | | Fold (f,a) -> 64 | Stack.fold (Fn.apply f) a st 65 | = List.fold_left (Fn.apply f) a s(*('a'::s)*) (* artificial injected bug *) 66 | 67 | let precond c s = match c with 68 | | Pop 69 | | Top -> s <> [] 70 | | Push _ 71 | | Clear 72 | | Is_empty 73 | | Length 74 | | Fold (_,_) -> true 75 | end 76 | 77 | module StT = QCSTM.Make(StConf) 78 | ;; 79 | QCheck_runner.run_tests ~verbose:true 80 | [StT.consistency_test ~count:1000 ~name:"stack-consistency"; 81 | StT.agree_test ~count:10_000 ~name:"stack-model"] 82 | -------------------------------------------------------------------------------- /examples/waterjug.ml: -------------------------------------------------------------------------------- 1 | open QCheck 2 | 3 | (* Example adapted from 4 | https://hypothesis.works/articles/how-not-to-die-hard-with-hypothesis/ and 5 | http://clrnd.com.ar/posts/2017-04-21-the-water-jug-problem-in-hedgehog.html *) 6 | module WJConf = 7 | struct 8 | type cmd = 9 | | FillBig 10 | | FillSmall 11 | | EmptyBig 12 | | EmptySmall 13 | | SmallIntoBig 14 | | BigIntoSmall [@@deriving show { with_path = false }] 15 | type state = { big : int; small : int } 16 | type sut = unit 17 | 18 | let arb_cmd s = 19 | QCheck.make ~print:show_cmd 20 | (Gen.oneofl [FillBig; FillSmall; EmptyBig; EmptySmall; SmallIntoBig; BigIntoSmall]) 21 | 22 | let init_state = { big = 0; small = 0} 23 | let next_state c s = match c with 24 | | FillBig -> { s with big = 5 } 25 | | FillSmall -> { s with small = 3 } 26 | | EmptyBig -> { s with big = 0 } 27 | | EmptySmall -> { s with small = 0 } 28 | | SmallIntoBig -> 29 | let big' = min 5 (s.big + s.small) in 30 | { big = big'; 31 | small = s.small - (big' - s.big) } 32 | | BigIntoSmall -> 33 | let small' = min 3 (s.big + s.small) in 34 | { big = s.big - (small' - s.small); 35 | small = small' } 36 | 37 | let init_sut _ = () 38 | let cleanup _ = () 39 | let run_cmd c s q = (next_state c s).big <> 4 (* s.big <> 4 *) 40 | 41 | let precond c s = true 42 | end 43 | 44 | module WJT = QCSTM.Make(WJConf) 45 | ;; 46 | QCheck_runner.run_tests ~verbose:true [WJT.agree_test ~count:10_000 ~name:"waterjug-model"] 47 | -------------------------------------------------------------------------------- /qcstm.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "qcstm" 3 | version: "0.1.1" 4 | synopsis: "A simple state-machine framework for OCaml based on QCheck" 5 | description: """ 6 | This library implements a simple, typed state machine framework for 7 | property-based testing of imperative code. Tests are described by 8 | (a generator of) symbolic commands and two command interpreters over 9 | an abstract model and the system under test. 10 | 11 | The library requires a recent installation of the QCheck framework. 12 | """ 13 | tags: [ 14 | "state machine" 15 | "test" 16 | "property" 17 | "quickcheck" 18 | ] 19 | license: "BSD-2-Clause" 20 | homepage: "https://github.com/jmid/qcstm" 21 | bug-reports: "https://github.com/jmid/qcstm/issues" 22 | authors: [ "Jan Midtgaard" ] 23 | maintainer: [ "Jan Midtgaard " ] 24 | dev-repo: "git+https://github.com/jmid/qcstm.git" 25 | url { 26 | src: "https://github.com/jmid/qcstm/archive/0.1.1.tar.gz" 27 | checksum: "md5=aea97b691038c9c93d1378ba4d5ad7ad" 28 | } 29 | depends: [ 30 | "ocaml" {>= "4.05.0"} 31 | "qcheck" {>= "0.8"} 32 | "ocamlfind" {build} 33 | "ocamlbuild" {build} 34 | "ppx_deriving" {with-test} 35 | "ctypes" {with-test} 36 | "ctypes-foreign" {with-test} 37 | ] 38 | 39 | build: [ 40 | [make "all"] 41 | ] 42 | 43 | install: [ 44 | [make "install"] 45 | [make "examples"] {with-test} 46 | ] 47 | -------------------------------------------------------------------------------- /src/qCSTM.ml: -------------------------------------------------------------------------------- 1 | (** A simple state machine framework based on QCheck *) 2 | open QCheck 3 | 4 | 5 | (** {1 A state machine framework for property-based testing of imperative code} *) 6 | 7 | (** This library implements a simple, typed state machine framework 8 | for property-based testing of imperative code. 9 | 10 | It takes inspiration from the commercial Erlang state machine framework from Quviq 11 | and ScalaCheck's state machine framework. 12 | *) 13 | 14 | (** The specification of a state machine. *) 15 | module type StmSpec = 16 | sig 17 | type cmd (** The type of commands *) 18 | type state (** The type of the model's state *) 19 | type sut (** The type of the system under test *) 20 | 21 | val arb_cmd : state -> cmd arbitrary 22 | (** A command generator. Accepts a state parameter to enable state-dependent [cmd] generation. *) 23 | 24 | val init_state : state 25 | (** The model's initial state. *) 26 | 27 | val next_state : cmd -> state -> state 28 | (** Move the internal state machine to the next state. *) 29 | 30 | 31 | val init_sut : unit -> sut 32 | (** The initial state of the system under test. *) 33 | 34 | val cleanup : sut -> unit 35 | (** Utility function to clean up the [sut] after each test instance, 36 | e.g., for closing sockets, files, or resetting global parameters*) 37 | 38 | val run_cmd : cmd -> state -> sut -> bool 39 | (** [run_cmd c s i] should interpret the command [c] over the system under test (typically side-effecting). 40 | [s] is in this case the model's state prior to command execution. 41 | The returned Boolean value should indicate whether the interpretation went well 42 | and in case [c] returns a value: whether the returned value agrees with the model's result. *) 43 | 44 | val precond : cmd -> state -> bool 45 | (** [precond c s] expresses preconditions for command [c]. 46 | This is useful, e.g., to prevent the shrinker from breaking invariants when minimizing 47 | counterexamples. *) 48 | end 49 | 50 | 51 | (** Derives a test framework from a state machine specification. *) 52 | module Make(Spec : StmSpec) (*: StmTest *) 53 | : sig 54 | val cmds_ok : Spec.state -> Spec.cmd list -> bool 55 | val arb_cmds : Spec.state -> Spec.cmd list arbitrary 56 | val consistency_test : ?count:int -> name:string -> Test.t 57 | val interp_agree : Spec.state -> Spec.sut -> Spec.cmd list -> bool 58 | val agree_prop : Spec.cmd list -> bool 59 | val agree_test : ?count:int -> name:string -> Test.t 60 | end 61 | = 62 | struct 63 | (** {3 The resulting test framework derived from a state machine specification} *) 64 | 65 | let rec gen_cmds s fuel = 66 | Gen.(if fuel = 0 67 | then return [] 68 | else 69 | (Spec.arb_cmd s).gen >>= fun c -> 70 | (gen_cmds (Spec.next_state c s) (fuel-1)) >>= fun cs -> 71 | return (c::cs)) 72 | (** A fueled command list generator. 73 | Accepts a state parameter to enable state-dependent [cmd] generation. *) 74 | 75 | let rec cmds_ok s cs = match cs with 76 | | [] -> true 77 | | c::cs -> 78 | Spec.precond c s && 79 | let s' = Spec.next_state c s in 80 | cmds_ok s' cs 81 | (** A precondition checker (stops early, thanks to short-circuit Boolean evaluation). 82 | Accepts the initial state and the command sequence as parameters. *) 83 | 84 | let arb_cmds s = 85 | let cmds_gen = Gen.sized (gen_cmds s) in 86 | let shrinker = match (Spec.arb_cmd s).shrink with 87 | | None -> Shrink.list ~shrink:Shrink.nil (* no elem. shrinker provided *) 88 | | Some s -> Shrink.list ~shrink:s in 89 | let ac = QCheck.make ~shrink:(Shrink.filter (cmds_ok Spec.init_state) shrinker) cmds_gen in 90 | (match (Spec.arb_cmd s).print with 91 | | None -> ac 92 | | Some p -> set_print (Print.list p) ac) 93 | (** A generator of command sequences. Accepts the initial state as parameter. *) 94 | 95 | let consistency_test ?(count=1000) ~name = 96 | Test.make ~name:name ~count:count (arb_cmds Spec.init_state) (cmds_ok Spec.init_state) 97 | (** A consistency test that generates a number of [cmd] sequences and 98 | checks that all contained [cmd]s satisfy the precondition [precond]. 99 | Accepts an optional [count] parameter and a test name as a labeled parameter [name]. *) 100 | 101 | let rec interp_agree s sut cs = match cs with 102 | | [] -> true 103 | | c::cs -> 104 | let b = Spec.run_cmd c s sut in 105 | let s' = Spec.next_state c s in 106 | b && interp_agree s' sut cs 107 | (** Checks agreement between the model and the system under test 108 | (stops early, thanks to short-circuit Boolean evaluation). *) 109 | 110 | let agree_prop = 111 | (fun cs -> 112 | assume (cmds_ok Spec.init_state cs); 113 | let sut = Spec.init_sut () in (* reset system's state *) 114 | let res = interp_agree Spec.init_state sut cs in 115 | let () = Spec.cleanup sut in 116 | res) 117 | (** The agreement property: the command sequence [cs] yields the same observations 118 | when interpreted from the model's initial state and the [sut]'s initial state. 119 | Cleans up after itself by calling [Spec.cleanup] *) 120 | 121 | let agree_test ?(count=1000) ~name = 122 | Test.make ~name:name ~count:count (arb_cmds Spec.init_state) agree_prop 123 | (** An actual agreement test (for convenience). Accepts an optional count parameter 124 | and a test name as a labeled parameter [name]. *) 125 | end 126 | -------------------------------------------------------------------------------- /src/qCSTM.odocl: -------------------------------------------------------------------------------- 1 | qCSTM 2 | --------------------------------------------------------------------------------