(*  Title:      Pure/Isar/outer_lex.ML

    ID:         $Id$

    Author:     Markus Wenzel, TU Muenchen

Outer lexical syntax for Isabelle/Isar.

*)

signature OUTER_LEX =

sig

  datatype token_kind =

    Command | Keyword | Ident | LongIdent | SymIdent | Var | TypeIdent | TypeVar | Nat |

    String | AltString | Verbatim | Space | Comment | Malformed | Error of string | Sync | EOF

  eqtype token

  val str_of_kind: token_kind -> string

  val stopper: token * (token -> bool)

  val not_sync: token -> bool

  val not_eof: token -> bool

  val position_of: token -> Position.T

  val pos_of: token -> string

  val kind_of: token -> token_kind

  val is_kind: token_kind -> token -> bool

  val keyword_with: (string -> bool) -> token -> bool

  val ident_with: (string -> bool) -> token -> bool

  val is_proper: token -> bool

  val is_semicolon: token -> bool

  val is_comment: token -> bool

  val is_begin_ignore: token -> bool

  val is_end_ignore: token -> bool

  val is_blank: token -> bool

  val is_newline: token -> bool

  val unparse: token -> string

  val text_of: token -> string * string

  val val_of: token -> string

  val is_sid: string -> bool

  val !!! : string -> (Position.T * 'a -> 'b) -> Position.T * 'a -> 'b

  val incr_line: ('a -> 'b * 'c) -> Position.T * 'a -> 'b * (Position.T * 'c)

  val keep_line: ('a -> 'b * 'c) -> Position.T * 'a -> 'b * (Position.T * 'c)

  val scan_blank: Position.T * Symbol.symbol list

    -> Symbol.symbol * (Position.T * Symbol.symbol list)

  val scan_string: Position.T * Symbol.symbol list -> string * (Position.T * Symbol.symbol list)

  val scan: (Scan.lexicon * Scan.lexicon) ->

    Position.T * Symbol.symbol list -> token * (Position.T * Symbol.symbol list)

  val source: bool option -> (unit -> Scan.lexicon * Scan.lexicon) ->

    Position.T -> (Symbol.symbol, 'a) Source.source ->

    (token, Position.T * (Symbol.symbol, 'a) Source.source) Source.source

  val source_proper: (token, 'a) Source.source ->

    (token, (token, 'a) Source.source) Source.source

  val make_lexicon: string list -> Scan.lexicon

end;

structure OuterLex: OUTER_LEX =

struct

(** tokens **)

(* datatype token *)

datatype token_kind =

  Command | Keyword | Ident | LongIdent | SymIdent | Var | TypeIdent | TypeVar | Nat |

  String | AltString | Verbatim | Space | Comment | Malformed | Error of string | Sync | EOF;

datatype token = Token of Position.T * (token_kind * string);

val str_of_kind =

 fn Command => "command"

  | Keyword => "keyword"

  | Ident => "identifier"

  | LongIdent => "long identifier"

  | SymIdent => "symbolic identifier"

  | Var => "schematic variable"

  | TypeIdent => "type variable"

  | TypeVar => "schematic type variable"

  | Nat => "number"

  | String => "string"

  | AltString => "back-quoted string"

  | Verbatim => "verbatim text"

  | Space => "white space"

  | Comment => "comment text"

  | Malformed => "malformed symbolic character"

  | Error _ => "bad input"

  | Sync => "sync marker"

  | EOF => "end-of-file";

(* control tokens *)

val eof = Token (Position.none, (EOF, ""));

fun is_eof (Token (_, (EOF, _))) = true

  | is_eof _ = false;

val stopper = (eof, is_eof);

val not_eof = not o is_eof;

fun not_sync (Token (_, (Sync, _))) = false

  | not_sync _ = true;

(* get position *)

fun position_of (Token (pos, _)) = pos;

val pos_of = Position.str_of o position_of;

(* kind of token *)

fun kind_of (Token (_, (k, _))) = k;

fun is_kind k (Token (_, (k', _))) = k = k';

fun keyword_with pred (Token (_, (Keyword, x))) = pred x

  | keyword_with _ _ = false;

fun ident_with pred (Token (_, (Ident, x))) = pred x

  | ident_with _ _ = false;

fun is_proper (Token (_, (Space, _))) = false

  | is_proper (Token (_, (Comment, _))) = false

  | is_proper _ = true;

fun is_semicolon (Token (_, (Keyword, ";"))) = true

  | is_semicolon _ = false;

fun is_comment (Token (_, (Comment, _))) = true

  | is_comment _ = false;

fun is_begin_ignore (Token (_, (Comment, "<"))) = true

  | is_begin_ignore _ = false;

fun is_end_ignore (Token (_, (Comment, ">"))) = true

  | is_end_ignore _ = false;

(* blanks and newlines -- space tokens obey lines *)

fun is_blank (Token (_, (Space, x))) = not (String.isSuffix "\n" x)

  | is_blank _ = false;

fun is_newline (Token (_, (Space, x))) = String.isSuffix "\n" x

  | is_newline _ = false;

(* token content *)

fun escape q =

  implode o map (fn s => if s = q orelse s = "\\" then "\\" ^ s else s) o Symbol.explode;

fun unparse (Token (_, (kind, x))) =

  (case kind of

    String => x |> quote o escape "\""

  | AltString => x |> enclose "`" "`" o escape "`"

  | Verbatim => x |> enclose "{*" "*}"

  | Comment => x |> enclose "(*" "*)"

  | Malformed => Output.escape_malformed x

  | Sync => ""

  | EOF => ""

  | _ => x);

fun text_of tok =

  if is_semicolon tok then ("terminator", "")

  else

    let

      val k = str_of_kind (kind_of tok);

      val s = unparse tok;

    in

      if s = "" then (k, "")

      else if size s < 40 andalso not (exists_string (fn c => c = "\n") s) then (k ^ " " ^ s, "")

      else (k, s)

    end;

fun val_of (Token (_, (_, x))) = x;

fun token_leq (Token (_, (_, x)), Token (_, (_, x'))) = x <= x';

(** scanners **)

fun change_prompt scan = Scan.prompt "# " scan;

(* diagnostics *)

fun lex_err msg ((pos, cs), _) = "Outer lexical error" ^ Position.str_of pos ^ ": " ^ msg cs;

fun !!! msg scan = Scan.!! (lex_err (K msg)) scan;

(* line numbering *)

fun incr_line scan = Scan.depend (fn pos => scan >> pair (Position.inc pos));

val keep_line = Scan.lift;

val scan_blank =

  incr_line ($$ "\n") ||

  keep_line (Scan.one Symbol.is_blank);

(* scan symbolic idents *)

val is_sym_char = member (op =) (explode "!#$%&*+-/<=>?@^_|~");

val scan_symid =

  Scan.many1 is_sym_char >> implode ||

  Scan.one Symbol.is_symbolic;

fun is_symid str =

  (case try Symbol.explode str of

    SOME [s] => Symbol.is_symbolic s orelse is_sym_char s

  | SOME ss => forall is_sym_char ss

  | _ => false);

fun is_sid "begin" = false

  | is_sid ":" = true

  | is_sid "::" = true

  | is_sid s = is_symid s orelse Syntax.is_identifier s;

(* scan strings *)

local

fun scan_str q =

  scan_blank ||

  keep_line ($$ "\\") |-- !!! "bad escape character in string"

      (scan_blank || keep_line ($$ q || $$ "\\")) ||

  keep_line (Scan.one (fn s => s <> q andalso s <> "\\" andalso Symbol.is_regular s));

fun scan_strs q =

  keep_line ($$ q) |--

    !!! "missing quote at end of string"

      (change_prompt ((Scan.repeat (scan_str q) >> implode) --| keep_line ($$ q)));

in

val scan_string = scan_strs "\"";

val scan_alt_string = scan_strs "`";

end;

(* scan verbatim text *)

val scan_verb =

  scan_blank ||

  keep_line ($$ "*" --| Scan.ahead (~$$ "}")) ||

  keep_line (Scan.one (fn s => s <> "*" andalso Symbol.is_regular s));

val scan_verbatim =

  keep_line ($$ "{" -- $$ "*") |--

    !!! "missing end of verbatim text"

      (change_prompt ((Scan.repeat scan_verb >> implode) --| keep_line ($$ "*" -- $$ "}")));

(* scan space *)

fun is_space s = Symbol.is_blank s andalso s <> "\n";

val scan_space =

  (keep_line (Scan.many1 is_space) -- Scan.optional (incr_line ($$ "\n")) "" ||

    keep_line (Scan.many is_space) -- incr_line ($$ "\n")) >> (fn (cs, c) => implode cs ^ c);

(* scan nested comments *)

val scan_cmt =

  Scan.lift scan_blank ||

  Scan.depend (fn d => keep_line ($$ "(" ^^ $$ "*") >> pair (d + 1)) ||

  Scan.depend (fn 0 => Scan.fail | d => keep_line ($$ "*" ^^ $$ ")") >> pair (d - 1)) ||

  Scan.lift (keep_line ($$ "*" --| Scan.ahead (~$$ ")"))) ||

  Scan.lift (keep_line (Scan.one (fn s => s <> "*" andalso Symbol.is_regular s)));

val scan_comment =

  keep_line ($$ "(" -- $$ "*") |--

    !!! "missing end of comment"

      (change_prompt

        (Scan.pass 0 (Scan.repeat scan_cmt >> implode) --| keep_line ($$ "*" -- $$ ")")));

(* scan malformed symbols *)

local

val scan_mal =

  scan_blank ||

  keep_line (Scan.one Symbol.is_regular);

in

val scan_malformed =

  keep_line ($$ Symbol.malformed) |--

    change_prompt (Scan.repeat scan_mal >> implode)

      --| keep_line (Scan.option ($$ Symbol.end_malformed));

end;

(* scan token *)

fun scan (lex1, lex2) =

  let

    val scanner = Scan.state :-- (fn pos =>

      let

        fun token k x = Token (pos, (k, x));

        fun sync _ = token Sync Symbol.sync;

      in

        scan_string >> token String ||

        scan_alt_string >> token AltString ||

        scan_verbatim >> token Verbatim ||

        scan_space >> token Space ||

        scan_comment >> token Comment ||

        scan_malformed >> token Malformed ||

        keep_line (Scan.one Symbol.is_sync >> sync) ||

        keep_line (Scan.max token_leq

          (Scan.max token_leq

            (Scan.literal lex1 >> (token Keyword o implode))

            (Scan.literal lex2 >> (token Command o implode)))

          (Syntax.scan_longid >> token LongIdent ||

            Syntax.scan_id >> token Ident ||

            Syntax.scan_var >> token Var ||

            Syntax.scan_tid >> token TypeIdent ||

            Syntax.scan_tvar >> token TypeVar ||

            Syntax.scan_nat >> token Nat ||

            scan_symid >> token SymIdent))

      end) >> #2;

  in !! (lex_err (fn cs => "bad input " ^ quote (Symbol.beginning 10 cs))) scanner end;

(* token sources *)

local

val is_junk = (not o Symbol.is_blank) andf Symbol.is_regular;

fun recover msg = Scan.state :-- (fn pos =>

  keep_line (Scan.many is_junk) >> (fn xs => [Token (pos, (Error msg, implode xs))])) >> #2;

in

fun source do_recover get_lex pos src =

  Source.source' pos Symbol.stopper (Scan.bulk (fn xs => scan (get_lex ()) xs))

    (Option.map (rpair recover) do_recover) src;

end;

fun source_proper src = src |> Source.filter is_proper;

(* lexicons *)

val make_lexicon = Scan.make_lexicon o map Symbol.explode;

end;