lib/mlton/basic/outstream0.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 Outstream0 =
   9 struct
  10
  11 structure TextIO = Pervasive.TextIO
  12 open TextIO
  13
  14 (*val output = fn (out, s) => (output (out, s); flushOut out) *)
  15
  16 type t = outstream
  17
  18 val standard = stdOut
  19 val error = stdErr
  20 val close = closeOut
  21 fun outputc stream string = output (stream, string)
  22 val flush = flushOut
  23
  24 fun newline s = output (s, "\n")
  25
  26 fun outputl (s, x) = (output (s, x); newline s)
  27
  28 fun print s = output (standard, s)
  29
  30 fun outputNothing _ = ()
  31
  32 fun set (o1: t, o2:t): unit =
  33    TextIO.setOutstream (o1, TextIO.getOutstream o2)
  34
  35 fun fluidLet (s1, s2, thunk) =
  36    let
  37       val old = TextIO.getOutstream s1
  38       val () = set (s1, s2)
  39    in
  40       Exn0.finally (thunk, fn () => TextIO.setOutstream (s1, old))
  41    end
  42
  43 fun withClose (out: t, f: t -> 'a): 'a =
  44    Exn0.finally (fn () => f out, fn () => close out)
  45
  46 local
  47    fun 'a withh (f, p: t -> 'a, openn): 'a =
  48       let
  49          val out = openn f handle IO.Io _ => Error.bug ("OutStream0.withh: cannot open " ^ f)
  50       in
  51          withClose (out, p)
  52       end
  53 in
  54    fun 'a withOut (f, p: t -> 'a): 'a = withh (f, p, openOut)
  55    fun withAppend (f, p) = withh (f, p, openAppend)
  56 end
  57
  58 fun 'a withNull (f: t -> 'a): 'a = withOut ("/dev/null", f)
  59
  60 fun ignore (out: t, f: unit -> 'a): 'a =
  61    withNull (fn out' => fluidLet (out, out', f))
  62
  63 end