src/Pure/General/source.ML
author wenzelm
Fri Nov 25 18:37:14 2011 +0100 (2011-11-25 ago)
changeset 45633 2cb7e34f6096
parent 40627 becf5d5187cc
child 54387 890e983cb07b
permissions -rw-r--r--
retain stderr and include it in syslog, which is buffered and thus increases the chance that users see remains from crashes etc.;
     1 (*  Title:      Pure/General/source.ML
     2     Author:     Markus Wenzel, TU Muenchen
     3 
     4 Coalgebraic data sources -- efficient purely functional input streams.
     5 *)
     6 
     7 signature SOURCE =
     8 sig
     9   type ('a, 'b) source
    10   val default_prompt: string
    11   val set_prompt: string -> ('a, 'b) source -> ('a, 'b) source
    12   val get: ('a, 'b) source -> 'a list * ('a, 'b) source
    13   val unget: 'a list * ('a, 'b) source -> ('a, 'b) source
    14   val get_single: ('a, 'b) source -> ('a * ('a, 'b) source) option
    15   val exhaust: ('a, 'b) source -> 'a list
    16   val map_filter: ('a -> 'b option) -> ('a, 'c) source -> ('b, ('a, 'c) source) source
    17   val filter: ('a -> bool) -> ('a, 'b) source -> ('a, ('a, 'b) source) source
    18   val of_list: 'a list -> ('a, 'a list) source
    19   val exhausted: ('a, 'b) source -> ('a, 'a list) source
    20   val of_string: string -> (string, string list) source
    21   val of_string_limited: int -> string -> (string, substring) source
    22   val tty: TextIO.instream -> (string, unit) source
    23   val source': 'a -> 'b Scan.stopper -> ('a * 'b list -> 'c list * ('a * 'b list)) ->
    24     (bool * (string -> 'a * 'b list -> 'c list * ('a * 'b list))) option ->
    25     ('b, 'e) source -> ('c, 'a * ('b, 'e) source) source
    26   val source: 'a Scan.stopper -> ('a list -> 'b list * 'a list) ->
    27     (bool * (string -> 'a list -> 'b list * 'a list)) option ->
    28     ('a, 'd) source -> ('b, ('a, 'd) source) source
    29 end;
    30 
    31 structure Source: SOURCE =
    32 struct
    33 
    34 
    35 (** datatype source **)
    36 
    37 datatype ('a, 'b) source =
    38   Source of
    39    {buffer: 'a list,
    40     info: 'b,
    41     prompt: string,
    42     drain: string -> 'b -> 'a list * 'b};
    43 
    44 fun make_source buffer info prompt drain =
    45   Source {buffer = buffer, info = info, prompt = prompt, drain = drain};
    46 
    47 
    48 (* prompt *)
    49 
    50 val default_prompt = "> ";
    51 
    52 fun set_prompt prompt (Source {buffer, info, prompt = _, drain}) =
    53   make_source buffer info prompt drain;
    54 
    55 
    56 (* get / unget *)
    57 
    58 fun get (Source {buffer = [], info, prompt, drain}) =
    59       let val (xs, info') = drain prompt info
    60       in (xs, make_source [] info' prompt drain) end
    61   | get (Source {buffer, info, prompt, drain}) =
    62       (buffer, make_source [] info prompt drain);
    63 
    64 fun unget (xs, Source {buffer, info, prompt, drain}) =
    65   make_source (xs @ buffer) info prompt drain;
    66 
    67 
    68 (* variations on get *)
    69 
    70 fun get_prompt prompt src = get (set_prompt prompt src);
    71 
    72 fun get_single src =
    73   (case get src of
    74     ([], _) => NONE
    75   | (x :: xs, src') => SOME (x, unget (xs, src')));
    76 
    77 fun exhaust src =
    78   (case get src of
    79     ([], _) => []
    80   | (xs, src') => xs @ exhaust src');
    81 
    82 
    83 (* (map)filter *)
    84 
    85 fun drain_map_filter f prompt src =
    86   let
    87     val (xs, src') = get_prompt prompt src;
    88     val xs' = map_filter f xs;
    89   in
    90     if null xs orelse not (null xs') then (xs', src')
    91     else drain_map_filter f prompt src'
    92   end;
    93 
    94 fun map_filter f src = make_source [] src default_prompt (drain_map_filter f);
    95 fun filter pred = map_filter (fn x => if pred x then SOME x else NONE);
    96 
    97 
    98 
    99 (** build sources **)
   100 
   101 (* list source *)
   102 
   103 fun of_list xs = make_source [] xs default_prompt (fn _ => fn xs => (xs, []));
   104 
   105 fun exhausted src = of_list (exhaust src);
   106 
   107 
   108 (* string source *)
   109 
   110 val of_string = of_list o raw_explode;
   111 
   112 fun of_string_limited limit str =
   113   make_source [] (Substring.full str) default_prompt
   114     (fn _ => fn s =>
   115       let
   116         val (s1, s2) = Substring.splitAt (s, Int.min (Substring.size s, limit));
   117         val cs = map String.str (Substring.explode s1);
   118       in (cs, s2) end);
   119 
   120 
   121 (* stream source *)
   122 
   123 fun slurp_input instream =
   124   let
   125     fun slurp () =
   126       (case TextIO.canInput (instream, 1) handle IO.Io _ => NONE of
   127         NONE => []
   128       | SOME 0 => []
   129       | SOME _ => TextIO.input instream :: slurp ());
   130   in maps raw_explode (slurp ()) end;
   131 
   132 fun tty in_stream = make_source [] () default_prompt (fn prompt => fn () =>
   133   let val input = slurp_input in_stream in
   134     if exists (fn c => c = "\n") input then (input, ())
   135     else
   136       (case (Output.prompt prompt; TextIO.inputLine in_stream) of
   137         SOME line => (input @ raw_explode line, ())
   138       | NONE => (input, ()))
   139   end);
   140 
   141 
   142 
   143 (** cascade sources **)
   144 
   145 (* state-based *)
   146 
   147 fun drain_source' stopper scan opt_recover prompt (state, src) =
   148   let
   149     val drain = Scan.drain prompt get_prompt stopper;
   150     val (xs, s) = get_prompt prompt src;
   151     val inp = ((state, xs), s);
   152     val ((ys, (state', xs')), src') =
   153       if null xs then (([], (state, [])), s)
   154       else
   155         (case opt_recover of
   156           NONE => drain (Scan.error scan) inp
   157         | SOME (interactive, recover) =>
   158             (drain (Scan.catch scan) inp handle Fail msg =>
   159               (if interactive then Output.error_msg msg else ();
   160                 drain (Scan.unless (Scan.lift (Scan.one (Scan.is_stopper stopper))) (recover msg)) inp)));
   161   in (ys, (state', unget (xs', src'))) end;
   162 
   163 fun source' init_state stopper scan recover src =
   164   make_source [] (init_state, src) default_prompt (drain_source' stopper scan recover);
   165 
   166 
   167 (* non state-based *)
   168 
   169 fun drain_source stopper scan opt_recover prompt =
   170   Scan.unlift (drain_source' stopper (Scan.lift scan)
   171     (Option.map (fn (int, r) => (int, Scan.lift o r)) opt_recover) prompt);
   172 
   173 fun source stopper scan recover src =
   174   make_source [] src default_prompt (drain_source stopper scan recover);
   175 
   176 
   177 end;