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