wenzelm@6118: (*  Title:      Pure/General/source.ML
wenzelm@6116:     ID:         $Id$
wenzelm@6116:     Author:     Markus Wenzel, TU Muenchen
wenzelm@6116: 
wenzelm@8806: Coalgebraic data sources -- efficient purely functional input streams.
wenzelm@6116: *)
wenzelm@6116: 
wenzelm@6116: signature SOURCE =
wenzelm@6116: sig
wenzelm@6116:   type ('a, 'b) source
wenzelm@6681:   val default_prompt: string
wenzelm@6116:   val set_prompt: string -> ('a, 'b) source -> ('a, 'b) source
wenzelm@6116:   val get: ('a, 'b) source -> 'a list * ('a, 'b) source
wenzelm@6116:   val unget: 'a list * ('a, 'b) source -> ('a, 'b) source
wenzelm@6116:   val get_single: ('a, 'b) source -> ('a * ('a, 'b) source) option
wenzelm@6116:   val exhaust: ('a, 'b) source -> 'a list
wenzelm@19485:   val map_filter: ('a -> 'b option) -> ('a, 'c) source -> ('b, ('a, 'c) source) source
wenzelm@6116:   val filter: ('a -> bool) -> ('a, 'b) source -> ('a, ('a, 'b) source) source
wenzelm@6116:   val of_list: 'a list -> ('a, 'a list) source
wenzelm@6116:   val of_string: string -> (string, string list) source
wenzelm@9123:   val exhausted: ('a, 'b) source -> ('a, 'a list) source
wenzelm@6116:   val of_stream: TextIO.instream -> TextIO.outstream -> (string, unit) source
wenzelm@6116:   val tty: (string, unit) source
wenzelm@6116:   val source': 'a -> 'b * ('b -> bool) -> ('a * 'b list -> 'c list * ('a * 'b list)) ->
wenzelm@23682:     (bool * (string -> 'a * 'b list -> 'c list * ('a * 'b list))) option ->
wenzelm@6116:     ('b, 'e) source -> ('c, 'a * ('b, 'e) source) source
wenzelm@6116:   val source: 'a * ('a -> bool) -> ('a list -> 'b list * 'a list) ->
wenzelm@23682:     (bool * (string -> 'a list -> 'b list * 'a list)) option ->
wenzelm@6116:     ('a, 'd) source -> ('b, ('a, 'd) source) source
wenzelm@6116: end;
wenzelm@6116: 
wenzelm@6116: structure Source: SOURCE =
wenzelm@6116: struct
wenzelm@6116: 
wenzelm@6116: 
wenzelm@6116: (** datatype source **)
wenzelm@6116: 
wenzelm@6116: datatype ('a, 'b) source =
wenzelm@6116:   Source of
wenzelm@6116:    {buffer: 'a list,
wenzelm@6116:     info: 'b,
wenzelm@6116:     prompt: string,
wenzelm@6116:     drain: string -> 'b -> 'a list * 'b};
wenzelm@6116: 
wenzelm@6116: fun make_source buffer info prompt drain =
wenzelm@6116:   Source {buffer = buffer, info = info, prompt = prompt, drain = drain};
wenzelm@6116: 
wenzelm@6116: 
wenzelm@6116: (* prompt *)
wenzelm@6116: 
wenzelm@6116: val default_prompt = "> ";
wenzelm@6116: 
wenzelm@6116: fun set_prompt prompt (Source {buffer, info, prompt = _, drain}) =
wenzelm@6116:   make_source buffer info prompt drain;
wenzelm@6116: 
wenzelm@6116: 
wenzelm@6116: (* get / unget *)
wenzelm@6116: 
wenzelm@6116: fun get (Source {buffer = [], info, prompt, drain}) =
wenzelm@6116:       let val (xs, info') = drain prompt info
wenzelm@6116:       in (xs, make_source [] info' prompt drain) end
wenzelm@6116:   | get (Source {buffer, info, prompt, drain}) =
wenzelm@6116:       (buffer, make_source [] info prompt drain);
wenzelm@6116: 
wenzelm@6116: fun unget (xs, Source {buffer, info, prompt, drain}) =
wenzelm@6116:   make_source (xs @ buffer) info prompt drain;
wenzelm@6116: 
wenzelm@6116: 
wenzelm@6116: (* variations on get *)
wenzelm@6116: 
wenzelm@6116: fun get_prompt prompt src = get (set_prompt prompt src);
wenzelm@6116: 
wenzelm@6116: fun get_single src =
wenzelm@6116:   (case get src of
skalberg@15531:     ([], _) => NONE
skalberg@15531:   | (x :: xs, src') => SOME (x, unget (xs, src')));
wenzelm@6116: 
wenzelm@6116: fun exhaust src =
wenzelm@6116:   (case get src of
wenzelm@6116:     ([], _) => []
wenzelm@6116:   | (xs, src') => xs @ exhaust src');
wenzelm@6116: 
wenzelm@6116: 
wenzelm@6116: (* (map)filter *)
wenzelm@6116: 
wenzelm@19485: fun drain_map_filter f prompt src =
wenzelm@6116:   let
wenzelm@6116:     val (xs, src') = get_prompt prompt src;
wenzelm@19485:     val xs' = map_filter f xs;
wenzelm@6116:   in
wenzelm@6116:     if null xs orelse not (null xs') then (xs', src')
wenzelm@19485:     else drain_map_filter f prompt src'
wenzelm@6116:   end;
wenzelm@6116: 
wenzelm@19485: fun map_filter f src = make_source [] src default_prompt (drain_map_filter f);
wenzelm@19485: fun filter pred = map_filter (fn x => if pred x then SOME x else NONE);
wenzelm@6116: 
wenzelm@6116: 
wenzelm@6116: 
wenzelm@6116: (** build sources **)
wenzelm@6116: 
wenzelm@6116: (* list source *)
wenzelm@6116: 
wenzelm@14727: fun of_list xs = make_source [] xs default_prompt (fn _ => fn xs => (xs, []));
wenzelm@6116: val of_string = of_list o explode;
wenzelm@6181: 
wenzelm@9123: fun exhausted src = of_list (exhaust src);
wenzelm@9123: 
wenzelm@6116: 
wenzelm@6116: (* stream source *)
wenzelm@6116: 
wenzelm@20737: fun slurp_input instream =
wenzelm@20737:   let
wenzelm@20737:     fun slurp () =
wenzelm@20737:       (case TextIO.canInput (instream, 1) handle IO.Io _ => NONE of
wenzelm@20737:         NONE => []
wenzelm@20737:       | SOME 0 => []
wenzelm@20737:       | SOME _ => TextIO.input instream :: slurp ());
wenzelm@20737:   in maps explode (slurp ()) end;
wenzelm@20737: 
wenzelm@6116: fun drain_stream instream outstream prompt () =
wenzelm@20737:   let val input = slurp_input instream in
wenzelm@20737:     if exists (fn c => c = "\n") input then (input, ())
wenzelm@20737:     else
wenzelm@23661:       (TextIO.output (outstream, Output.output prompt);
wenzelm@20737:         TextIO.flushOut outstream;
wenzelm@23139:         (case TextIO.inputLine instream of
wenzelm@23139:           SOME line => (input @ explode line, ())
wenzelm@23139:         | NONE => (input, ())))
wenzelm@20737:   end;
wenzelm@6116: 
wenzelm@6116: fun of_stream instream outstream =
wenzelm@6116:   make_source [] () default_prompt (drain_stream instream outstream);
wenzelm@6116: 
wenzelm@6116: val tty = of_stream TextIO.stdIn TextIO.stdOut;
wenzelm@6116: 
wenzelm@6116: 
wenzelm@6116: 
wenzelm@23700: (** cascade sources **)
wenzelm@6116: 
wenzelm@6116: (* state-based *)
wenzelm@6116: 
wenzelm@23700: fun drain_source' stopper scan opt_recover prompt (state, src) =
wenzelm@23700:   let
wenzelm@23700:     val drain = Scan.drain prompt get_prompt stopper;
wenzelm@23700:     val (xs, s) = get_prompt prompt src;
wenzelm@23700:     val inp = ((state, xs), s);
wenzelm@23700:     val ((ys, (state', xs')), src') =
wenzelm@23700:       if null xs then (([], (state, [])), s)
wenzelm@23700:       else
wenzelm@23700:         (case opt_recover of
wenzelm@23700:           NONE => drain (Scan.error scan) inp
wenzelm@23700:         | SOME (interactive, recover) =>
wenzelm@23700:             (drain (Scan.catch scan) inp handle Fail msg =>
wenzelm@23700:               (if interactive then Output.error_msg msg else ();
wenzelm@23700:                 drain (Scan.unless (Scan.lift (Scan.one (#2 stopper))) (recover msg)) inp)));
wenzelm@23700:   in (ys, (state', unget (xs', src'))) end;
wenzelm@23700: 
wenzelm@6116: fun source' init_state stopper scan recover src =
wenzelm@23700:   make_source [] (init_state, src) default_prompt (drain_source' stopper scan recover);
wenzelm@6116: 
wenzelm@6116: 
wenzelm@6116: (* non state-based *)
wenzelm@6116: 
wenzelm@23700: fun drain_source stopper scan opt_recover prompt =
wenzelm@23700:   Scan.unlift (drain_source' stopper (Scan.lift scan)
wenzelm@23700:     (Option.map (fn (int, r) => (int, Scan.lift o r)) opt_recover) prompt);
wenzelm@23700: 
wenzelm@6116: fun source stopper scan recover src =
wenzelm@23700:   make_source [] src default_prompt (drain_source stopper scan recover);
wenzelm@6116: 
wenzelm@6116: 
wenzelm@6116: end;