mlton/backend/err.sml

   1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  * Copyright (C) 1997-2000 NEC Research Institute.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 structure Err =
  10    struct
  11       datatype t = T of {inner: t option,
  12                          name: string,
  13                          obj: Layout.t}
  14
  15       fun layout (T {inner, name, obj}): Layout.t =
  16          let
  17             open Layout
  18          in
  19             align [case inner of
  20                       NONE => empty
  21                     | SOME e => layout e,
  22                    seq [str (concat ["invalid ", name, ": "]), obj]]
  23          end
  24
  25       exception E of t
  26
  27       fun check' (name: string,
  28                   ok: unit -> 'a option,
  29                   layout: unit -> Layout.t): 'a =
  30          case ok () handle E e => raise E (T {inner = SOME e,
  31                                               name = name,
  32                                               obj = layout ()}) of
  33             NONE => raise E (T {inner = NONE,
  34                                 name = name,
  35                                 obj = layout ()})
  36           | SOME a => a
  37
  38       fun boolToUnitOpt b = if b then SOME () else NONE
  39
  40       fun check (name, ok, layout) =
  41          check' (name, boolToUnitOpt o ok, layout)
  42    end