lib/mlton/basic/assert.sml

   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