src/Pure/Thy/term_style.ML
author wenzelm
Mon Mar 10 16:30:07 2014 +0100 (2014-03-10)
changeset 56029 8bedca4bd5a3
parent 53171 a5e54d4d9081
child 56030 ef2ffd622264
permissions -rw-r--r--
clarified Args.src: more abstract type, position refers to name only;
prefer self-contained Args.check_src;
     1 (*  Title:      Pure/Thy/term_style.ML
     2     Author:     Florian Haftmann, TU Muenchen
     3 
     4 Styles for term printing.
     5 *)
     6 
     7 signature TERM_STYLE =
     8 sig
     9   val setup: string -> (Proof.context -> term -> term) parser -> theory -> theory
    10   val parse: (term -> term) context_parser
    11 end;
    12 
    13 structure Term_Style: TERM_STYLE =
    14 struct
    15 
    16 (* style data *)
    17 
    18 fun err_dup_style name =
    19   error ("Duplicate declaration of antiquote style: " ^ quote name);
    20 
    21 structure Styles = Theory_Data
    22 (
    23   type T = ((Proof.context -> term -> term) parser * stamp) Symtab.table;
    24   val empty = Symtab.empty;
    25   val extend = I;
    26   fun merge data : T = Symtab.merge (eq_snd (op =)) data
    27     handle Symtab.DUP dup => err_dup_style dup;
    28 );
    29 
    30 
    31 (* accessors *)
    32 
    33 fun the_style thy name =
    34   (case Symtab.lookup (Styles.get thy) name of
    35     NONE => error ("Unknown antiquote style: " ^ quote name)
    36   | SOME (style, _) => style);
    37 
    38 fun setup name style thy =
    39   Styles.map (Symtab.update_new (name, (style, stamp ()))) thy
    40     handle Symtab.DUP _ => err_dup_style name;
    41 
    42 
    43 (* style parsing *)
    44 
    45 fun parse_single ctxt = Parse.position Parse.xname -- Args.parse
    46   >> (fn ((name, pos), args) => fst (Args.context_syntax "style"
    47        (Scan.lift (the_style (Proof_Context.theory_of ctxt) name))
    48          (Args.src (name, pos) args) ctxt |>> (fn f => f ctxt)));
    49 
    50 val parse = Args.context :|-- (fn ctxt => Scan.lift
    51   (Args.parens (parse_single ctxt ::: Scan.repeat (Args.$$$ "," |-- parse_single ctxt))
    52       >> fold I
    53   || Scan.succeed I));
    54 
    55 
    56 (* predefined styles *)
    57 
    58 fun style_lhs_rhs proj = Scan.succeed (fn ctxt => fn t =>
    59   let
    60     val concl =
    61       Object_Logic.drop_judgment (Proof_Context.theory_of ctxt) (Logic.strip_imp_concl t)
    62   in
    63     (case concl of
    64       (_ $ l $ r) => proj (l, r)
    65     | _ => error ("Binary operator expected in term: " ^ Syntax.string_of_term ctxt concl))
    66   end);
    67 
    68 val style_prem = Parse.nat >> (fn i => fn ctxt => fn t =>
    69   let
    70     val prems = Logic.strip_imp_prems t;
    71   in
    72     if i <= length prems then nth prems (i - 1)
    73     else
    74       error ("Not enough premises for prem " ^ string_of_int i ^
    75         " in propositon: " ^ Syntax.string_of_term ctxt t)
    76   end);
    77 
    78 fun sub_symbols (d :: s :: ss) =
    79       if Symbol.is_ascii_digit d andalso not (String.isPrefix ("\\<^") s)
    80       then d :: "\\<^sub>" :: sub_symbols (s :: ss)
    81       else d :: s :: ss
    82   | sub_symbols cs = cs;
    83 
    84 val sub_name = implode o rev o sub_symbols o rev o Symbol.explode;
    85 
    86 fun sub_term (Free (n, T)) = Free (sub_name n, T)
    87   | sub_term (Var ((n, idx), T)) =
    88       if idx <> 0 then Var ((sub_name (n ^ string_of_int idx), 0), T)
    89       else Var ((sub_name n, 0), T)
    90   | sub_term (t $ u) = sub_term t $ sub_term u
    91   | sub_term (Abs (n, T, b)) = Abs (sub_name n, T, sub_term b)
    92   | sub_term t = t;
    93 
    94 val _ = Theory.setup
    95  (setup "lhs" (style_lhs_rhs fst) #>
    96   setup "rhs" (style_lhs_rhs snd) #>
    97   setup "prem" style_prem #>
    98   setup "concl" (Scan.succeed (K Logic.strip_imp_concl)) #>
    99   setup "sub" (Scan.succeed (K sub_term)));
   100 
   101 end;