Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * | |
4 | * MLton is released under a BSD-style license. | |
5 | * See the file MLton-LICENSE for details. | |
6 | *) | |
7 | ||
8 | structure Assert: ASSERT = | |
9 | struct | |
10 | val debug = MLton.debug orelse (not MLton.isMLton) | |
11 | ||
12 | fun fail msg = Error.bug (concat ["assertion failure: ", msg]) | |
13 | ||
14 | fun assert (msg: string, f: unit -> bool): unit = | |
15 | if debug andalso not (f () handle _ => false) | |
16 | then fail msg | |
17 | else () | |
18 | ||
19 | fun assert' (msg, b) = assert (msg, fn () => b) | |
20 | ||
21 | val ('a, 'b) assertFun': | |
22 | string | |
23 | * ('a -> 'b) | |
24 | * ('a -> bool * ('b -> bool * 'b)) | |
25 | -> 'a -> 'b = | |
26 | (* Can't do what I really want because of the value restriction. | |
27 | * Would like to write: | |
28 | * if debug then (fn ... => ...) else (fn ... => ...). | |
29 | *) | |
30 | fn (msg, f, check) => | |
31 | if debug | |
32 | then (fn a => | |
33 | let val (yes, check) = check a | |
34 | val _ = assert' (concat [msg, " argument"], yes) | |
35 | val (yes, b) = check (f a) | |
36 | in assert' (concat [msg, " result"], yes) | |
37 | ; b | |
38 | end) | |
39 | else f | |
40 | ||
41 | fun assertFun (msg, | |
42 | f: 'a -> 'b, | |
43 | check: 'a -> bool * ('b -> bool)): 'a -> 'b = | |
44 | assertFun' (msg, f, | |
45 | fn a => let val (yes, check) = check a | |
46 | in (yes, fn b => (check b, b)) | |
47 | end) | |
48 | ||
49 | fun assertFun2 (msg, | |
50 | f: 'a -> 'b -> 'c, | |
51 | check: 'a -> bool * ('b -> (bool * ('c -> bool)))) = | |
52 | assertFun' | |
53 | (msg, f, | |
54 | fn a => let val (yes, check) = check a | |
55 | in (yes, | |
56 | fn bc => (true, assertFun (msg, bc, check))) | |
57 | end) | |
58 | end |