mlton/control/system.sml

   1 (* Copyright (C) 1999-2005 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 System: SYSTEM =
  10    struct
  11       fun insertBackslashes (ss: string list,
  12                              width: int,
  13                              indent: int): string list =
  14          let
  15             val indentation = String.make (indent, #" ")
  16             fun loop (ss, pos, line, lines) =
  17                (* pos + 2 < width (so the backslash can be inserted) *)
  18                case ss of
  19                   [] => rev (concat (rev line) :: lines)
  20                 | s :: ss =>
  21                      let
  22                         val n = String.size s
  23                         val (pos, line') =
  24                            case line of
  25                               [] => (pos + n, [s])
  26                             | _ => (pos + n + 1, s :: " " :: line)
  27                         fun newLine () =
  28                            loop (ss, indent + n, [s, indentation],
  29                                  concat (rev (" \\" :: line)) :: lines)
  30                      in
  31                         if pos <= width
  32                            then
  33                               case ss of
  34                                  [] => rev (concat (rev line') :: lines)
  35                                | _ =>
  36                                     if pos + 2 <= width
  37                                        then loop (ss, pos, line', lines)
  38                                     else newLine ()
  39                         else newLine ()
  40                      end
  41          in loop (ss, 0, [], [])
  42          end
  43
  44       fun system (com: string, args: string list): unit =
  45          let
  46             (* Many terminal emulators do the line folding one character early,
  47              * so we use 79 instead of 80 columns.
  48              *)
  49             val width = 79
  50             val indentAmount = 4
  51             val s = concat (List.separate (com :: args, " "))
  52             val _ =
  53                let
  54                   open Control
  55                in
  56                   message (Top, fn () =>
  57                            Layout.align
  58                            (List.map (insertBackslashes
  59                                       (com :: args,
  60                                        width - getDepth (),
  61                                        indentAmount),
  62                                       Layout.str)))
  63                end
  64          in
  65             Process.wait (MLton.Process.spawnp {file = com, args = com :: args})
  66             handle e => Error.bug (concat ["call to system failed with ",
  67                                            Exn.toString e, ":\n", s])
  68          end
  69    end