File ‹Tools/literal.ML›

(*  Title:      HOL/Tools/literal.ML
    Author:     Florian Haftmann, TU Muenchen

Logical and syntactic operations on literals (see also HOL/Tools/hologic.ML).
*)

signature LITERAL =
sig
  val add_code: string -> theory -> theory
end

structure Literal: LITERAL =
struct

datatype character = datatype String_Syntax.character;

fun mk_literal_syntax [] = Syntax.const \<^const_syntax>‹String.empty_literal›
  | mk_literal_syntax (c :: cs) =
      list_comb (Syntax.const \<^const_syntax>‹String.Literal›, String_Syntax.mk_bits_syntax 7 c)
        $ mk_literal_syntax cs;

val dest_literal_syntax =
  let
    fun dest (Const (\<^const_syntax>‹String.empty_literal›, _)) = []
      | dest (Const (\<^const_syntax>‹String.Literal›, _) $ b0 $ b1 $ b2 $ b3 $ b4 $ b5 $ b6 $ t) =
          String_Syntax.classify_character (String_Syntax.dest_bits_syntax [b0, b1, b2, b3, b4, b5, b6]) :: dest t
      | dest t = raise Match;
  in dest end;

fun ascii_tr [(c as Const (\<^syntax_const>‹_constrain›, _)) $ t $ u] =
      c $ ascii_tr [t] $ u
  | ascii_tr [Const (num, _)] =
      (mk_literal_syntax o single o (fn n => n mod 128) o #value o Lexicon.read_num) num
  | ascii_tr ts = raise TERM ("ascii_tr", ts);

fun literal_tr [(c as Const (\<^syntax_const>‹_constrain›, _)) $ t $ u] =
      c $ literal_tr [t] $ u
  | literal_tr [Free (str, _)] =
      (mk_literal_syntax o map String_Syntax.ascii_ord_of o String_Syntax.plain_strings_of) str
  | literal_tr ts = raise TERM ("literal_tr", ts);

fun ascii k = Syntax.const \<^syntax_const>‹_Ascii›
  $ Syntax.free (String_Syntax.hex k);

fun literal cs = Syntax.const \<^syntax_const>‹_Literal›
  $ Syntax.const (Lexicon.implode_str cs);

fun empty_literal_tr' _ = literal [];

fun literal_tr' [b0, b1, b2, b3, b4, b5, b6, t] =
      let
        val cs =
          dest_literal_syntax (list_comb (Syntax.const \<^const_syntax>‹String.Literal›, [b0, b1, b2, b3, b4, b5, b6, t]))
        fun is_printable (Char _) = true
          | is_printable (Ord _) = false;
        fun the_char (Char c) = c;
        fun the_ascii [Ord i] = i;
      in
        if forall is_printable cs
        then literal (map the_char cs)
        else if length cs = 1
        then ascii (the_ascii cs)
        else raise Match
      end
  | literal_tr' _ = raise Match;

open Basic_Code_Thingol;

fun map_partial g f =
  let
    fun mapp [] = SOME []
      | mapp (x :: xs) =
          (case f x of
            NONE => NONE
          | SOME y => 
            (case mapp xs of
              NONE => NONE
            | SOME ys => SOME (y :: ys)))
  in Option.map g o mapp end;

fun implode_bit (IConst { sym = Code_Symbol.Constant \<^const_name>‹False›, ... }) = SOME 0
  | implode_bit (IConst { sym = Code_Symbol.Constant \<^const_name>‹True›, ... }) = SOME 1
  | implode_bit _ = NONE

fun implode_ascii (b0, b1, b2, b3, b4, b5, b6) =
  map_partial (chr o Integer.eval_radix 2) implode_bit [b0, b1, b2, b3, b4, b5, b6];

fun implode_literal b0 b1 b2 b3 b4 b5 b6 t =
  let
    fun dest_literal (IConst { sym = Code_Symbol.Constant \<^const_name>‹String.Literal›, ... }
          `$ b0 `$ b1 `$ b2 `$ b3 `$ b4 `$ b5 `$ b6 `$ t) = SOME ((b0, b1, b2, b3, b4, b5, b6), t)
      | dest_literal _ = NONE;
    val (bss', t') = Code_Thingol.unfoldr dest_literal t;
    val bss = (b0, b1, b2, b3, b4, b5, b6) :: bss';
  in
    case t' of
      IConst { sym = Code_Symbol.Constant \<^const_name>‹String.zero_literal_inst.zero_literal›, ... }
        => map_partial implode implode_ascii bss
    | _ => NONE
  end;

fun add_code target thy =
  let
    fun pretty literals _ thm _ _ [(b0, _), (b1, _), (b2, _), (b3, _), (b4, _), (b5, _), (b6, _), (t, _)] =
      case implode_literal b0 b1 b2 b3 b4 b5 b6 t of
        SOME s => (Code_Printer.str o Code_Printer.literal_string literals) s
      | NONE => Code_Printer.eqn_error thy thm "Illegal string literal expression";
  in
    thy
    |> Code_Target.set_printings (Code_Symbol.Constant (\<^const_name>‹String.Literal›,
      [(target, SOME (Code_Printer.complex_const_syntax (8, pretty)))]))
  end;

val _ =
  Theory.setup
   (Sign.parse_translation
     [(\<^syntax_const>‹_Ascii›, K ascii_tr),
      (\<^syntax_const>‹_Literal›, K literal_tr)] #>
    Sign.print_translation
     [(\<^const_syntax>‹String.Literal›, K literal_tr'),
      (\<^const_syntax>‹String.empty_literal›, K empty_literal_tr')]);

end