src/Pure/Syntax/syntax_phases.ML
changeset 81165 0278f6d87bad
parent 81164 aed72f8dc9c1
child 81166 26ecbac09941
equal deleted inserted replaced
81164:aed72f8dc9c1 81165:0278f6d87bad
   656       | mark a = a;
   656       | mark a = a;
   657   in mark tm end;
   657   in mark tm end;
   658 
   658 
   659 in
   659 in
   660 
   660 
   661 fun term_to_ast ctxt trf tm =
   661 fun term_to_ast ctxt trf term =
   662   let
   662   let
   663     val show_types = Config.get ctxt show_types orelse Config.get ctxt show_sorts;
   663     val show_types = Config.get ctxt show_types orelse Config.get ctxt show_sorts;
   664     val show_markup = Config.get ctxt show_markup;
   664     val show_markup = Config.get ctxt show_markup;
   665 
   665 
   666     fun constrain_ast T ast =
   666     fun constrain_ast clean T ast =
   667       Ast.Appl [Ast.Constant "_constrain", ast, ast_of_termT ctxt trf (term_of_typ ctxt T)];
   667       if T = dummyT then ast
       
   668       else
       
   669         let val U = Type_Annotation.print clean T
       
   670         in Ast.Appl [Ast.Constant "_constrain", ast, ast_of_termT ctxt trf (term_of_typ ctxt U)] end;
   668 
   671 
   669     fun ast_of tm =
   672     fun ast_of tm =
   670       (case strip_comb tm of
   673       (case strip_comb tm of
   671         (t as Abs _, ts) => Ast.mk_appl (ast_of (Syntax_Trans.abs_tr' ctxt t)) (map ast_of ts)
   674         (t as Abs _, ts) => Ast.mk_appl (ast_of (Syntax_Trans.abs_tr' ctxt t)) (map ast_of ts)
   672       | ((c as Const ("_free", _)), Free (x, T) :: ts) =>
   675       | ((c as Const ("_free", _)), Free (x, T) :: ts) =>
   686 
   689 
   687     and trans a T args = ast_of (trf a ctxt T args)
   690     and trans a T args = ast_of (trf a ctxt T args)
   688       handle Match => Ast.mk_appl (Ast.Constant a) (map ast_of args)
   691       handle Match => Ast.mk_appl (Ast.Constant a) (map ast_of args)
   689 
   692 
   690     and var_ast v T =
   693     and var_ast v T =
   691       if (show_types orelse show_markup) andalso T <> dummyT then
   694       simple_ast_of ctxt v
   692         let
   695       |> (show_types orelse show_markup) ?
   693           val T' =
   696           constrain_ast {clean = show_markup andalso not show_types} T;
   694             if show_markup andalso not show_types
       
   695             then Type_Annotation.clean T
       
   696             else Type_Annotation.smash T;
       
   697         in simple_ast_of ctxt v |> constrain_ast T' end
       
   698       else simple_ast_of ctxt v;
       
   699   in
   697   in
   700     tm
   698     term
   701     |> mark_aprop
   699     |> mark_aprop
   702     |> show_types ? prune_types
   700     |> show_types ? prune_types
   703     |> Variable.revert_bounds ctxt
   701     |> Variable.revert_bounds ctxt
   704     |> mark_atoms ctxt
   702     |> mark_atoms ctxt
   705     |> ast_of
   703     |> ast_of