| 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 |