src/Tools/code/code_target.ML
changeset 26010 a741416574e1
parent 25985 8d69087f6a4b
child 26086 3c243098b64a
equal deleted inserted replaced
26009:b6a64fe38634 26010:a741416574e1
    36     -> string option -> Args.T list
    36     -> string option -> Args.T list
    37     -> string list option -> CodeThingol.code -> unit;
    37     -> string list option -> CodeThingol.code -> unit;
    38   val assert_serializer: theory -> string -> string;
    38   val assert_serializer: theory -> string -> string;
    39 
    39 
    40   val eval_verbose: bool ref;
    40   val eval_verbose: bool ref;
    41   val eval_invoke: theory -> (string * (unit -> 'a) option ref)
    41   val eval: theory -> (string * (unit -> 'a) option ref)
    42     -> CodeThingol.code -> CodeThingol.iterm * CodeThingol.itype -> string list -> 'a;
    42     -> CodeThingol.code -> CodeThingol.iterm * CodeThingol.itype -> string list -> 'a;
    43   val code_width: int ref;
    43   val code_width: int ref;
    44 
    44 
    45   val setup: theory -> theory;
    45   val setup: theory -> theory;
    46 end;
    46 end;
    73   | NOBR
    73   | NOBR
    74   | INFX of (int * lrx);
    74   | INFX of (int * lrx);
    75 
    75 
    76 val APP = INFX (~1, L);
    76 val APP = INFX (~1, L);
    77 
    77 
    78 fun eval_lrx L L = false
    78 fun fixity_lrx L L = false
    79   | eval_lrx R R = false
    79   | fixity_lrx R R = false
    80   | eval_lrx _ _ = true;
    80   | fixity_lrx _ _ = true;
    81 
    81 
    82 fun eval_fxy NOBR NOBR = false
    82 fun fixity NOBR NOBR = false
    83   | eval_fxy BR NOBR = false
    83   | fixity BR NOBR = false
    84   | eval_fxy NOBR BR = false
    84   | fixity NOBR BR = false
    85   | eval_fxy (INFX (pr, lr)) (INFX (pr_ctxt, lr_ctxt)) =
    85   | fixity (INFX (pr, lr)) (INFX (pr_ctxt, lr_ctxt)) =
    86       pr < pr_ctxt
    86       pr < pr_ctxt
    87       orelse pr = pr_ctxt
    87       orelse pr = pr_ctxt
    88         andalso eval_lrx lr lr_ctxt
    88         andalso fixity_lrx lr lr_ctxt
    89       orelse pr_ctxt = ~1
    89       orelse pr_ctxt = ~1
    90   | eval_fxy _ (INFX _) = false
    90   | fixity _ (INFX _) = false
    91   | eval_fxy (INFX _) NOBR = false
    91   | fixity (INFX _) NOBR = false
    92   | eval_fxy _ _ = true;
    92   | fixity _ _ = true;
    93 
    93 
    94 fun gen_brackify _ [p] = p
    94 fun gen_brackify _ [p] = p
    95   | gen_brackify true (ps as _::_) = Pretty.enclose "(" ")" ps
    95   | gen_brackify true (ps as _::_) = Pretty.enclose "(" ")" ps
    96   | gen_brackify false (ps as _::_) = Pretty.block ps;
    96   | gen_brackify false (ps as _::_) = Pretty.block ps;
    97 
    97 
    98 fun brackify fxy_ctxt ps =
    98 fun brackify fxy_ctxt ps =
    99   gen_brackify (eval_fxy BR fxy_ctxt) (Pretty.breaks ps);
    99   gen_brackify (fixity BR fxy_ctxt) (Pretty.breaks ps);
   100 
   100 
   101 fun brackify_infix infx fxy_ctxt ps =
   101 fun brackify_infix infx fxy_ctxt ps =
   102   gen_brackify (eval_fxy (INFX infx) fxy_ctxt) (Pretty.breaks ps);
   102   gen_brackify (fixity (INFX infx) fxy_ctxt) (Pretty.breaks ps);
   103 
   103 
   104 type class_syntax = string * (string -> string option);
   104 type class_syntax = string * (string -> string option);
   105 type typ_syntax = int * ((fixity -> itype -> Pretty.T)
   105 type typ_syntax = int * ((fixity -> itype -> Pretty.T)
   106   -> fixity -> itype list -> Pretty.T);
   106   -> fixity -> itype list -> Pretty.T);
   107 type term_syntax = int * ((CodeName.var_ctxt -> fixity -> iterm -> Pretty.T)
   107 type term_syntax = int * ((CodeName.var_ctxt -> fixity -> iterm -> Pretty.T)
   129           error ("Inconsistent mixfix: too many arguments")
   129           error ("Inconsistent mixfix: too many arguments")
   130       | fillin _ _ [] =
   130       | fillin _ _ [] =
   131           error ("Inconsistent mixfix: too less arguments");
   131           error ("Inconsistent mixfix: too less arguments");
   132   in
   132   in
   133     (i, fn pr => fn fixity_ctxt => fn args =>
   133     (i, fn pr => fn fixity_ctxt => fn args =>
   134       gen_brackify (eval_fxy fixity_this fixity_ctxt) (fillin pr mfx args))
   134       gen_brackify (fixity fixity_this fixity_ctxt) (fillin pr mfx args))
   135   end;
   135   end;
   136 
   136 
   137 fun parse_infix prep_arg (x, i) s =
   137 fun parse_infix prep_arg (x, i) s =
   138   let
   138   let
   139     val l = case x of L => INFX (i, L) | _ => INFX (i, X);
   139     val l = case x of L => INFX (i, L) | _ => INFX (i, X);
  1388           | pr_monad (SOME (bind, false), t) vars = vars
  1388           | pr_monad (SOME (bind, false), t) vars = vars
  1389               |> pr_bind NOBR bind
  1389               |> pr_bind NOBR bind
  1390               |>> (fn p => semicolon [str "let", p, str "=", pr vars NOBR t]);
  1390               |>> (fn p => semicolon [str "let", p, str "=", pr vars NOBR t]);
  1391         val (binds, t) = implode_monad c_bind t;
  1391         val (binds, t) = implode_monad c_bind t;
  1392         val (ps, vars') = fold_map pr_monad binds vars;
  1392         val (ps, vars') = fold_map pr_monad binds vars;
  1393         fun brack p = if eval_fxy BR fxy then Pretty.block [str "(", p, str ")"] else p;
  1393         fun brack p = if fixity BR fxy then Pretty.block [str "(", p, str ")"] else p;
  1394       in (brack o Pretty.block_enclose (str "do {", str "}")) (ps @| pr vars' NOBR t) end;
  1394       in (brack o Pretty.block_enclose (str "do {", str "}")) (ps @| pr vars' NOBR t) end;
  1395   in (1, pretty) end;
  1395   in (1, pretty) end;
  1396 
  1396 
  1397 end; (*local*)
  1397 end; (*local*)
  1398 
  1398 
  1713     #> check_empty_funs
  1713     #> check_empty_funs
  1714     #> seri module file args (CodeName.labelled_name thy) reserved includes
  1714     #> seri module file args (CodeName.labelled_name thy) reserved includes
  1715         (Symtab.lookup alias) (Symtab.lookup class) (Symtab.lookup tyco) (Symtab.lookup const)
  1715         (Symtab.lookup alias) (Symtab.lookup class) (Symtab.lookup tyco) (Symtab.lookup const)
  1716   end;
  1716   end;
  1717 
  1717 
  1718 fun eval_invoke thy (ref_name, reff) code (t, ty) args =
  1718 fun eval thy (ref_name, reff) code (t, ty) args =
  1719   let
  1719   let
  1720     val _ = if CodeThingol.contains_dictvar t then
  1720     val _ = if CodeThingol.contains_dictvar t then
  1721       error "Term to be evaluated constains free dictionaries" else ();
  1721       error "Term to be evaluated constains free dictionaries" else ();
  1722     val val_args = space_implode " "
  1722     val val_args = space_implode " "
  1723       (NameSpace.qualifier CodeName.value_name :: map (enclose "(" ")") args);
  1723       (NameSpace.qualifier CodeName.value_name :: map (enclose "(" ")") args);
       
  1724     val code' = CodeThingol.add_value_stmt (t, ty) code;
  1724     val seri = get_serializer thy "SML" false (SOME "Isabelle_Eval") NONE [];
  1725     val seri = get_serializer thy "SML" false (SOME "Isabelle_Eval") NONE [];
  1725     val code' = CodeThingol.add_value_stmt (t, ty) code;
       
  1726     val label = "evaluation in SML";
  1726     val label = "evaluation in SML";
  1727     fun eval () = (seri (SOME [CodeName.value_name]) code';
  1727     fun eval () = (seri (SOME [CodeName.value_name]) code';
  1728       ML_Context.evaluate Output.ml_output (!eval_verbose) (ref_name, reff) val_args);
  1728       ML_Context.evaluate Output.ml_output (!eval_verbose) (ref_name, reff) val_args);
  1729   in NAMED_CRITICAL label eval end;
  1729   in NAMED_CRITICAL label eval end;
  1730 
  1730 
  2196   add_serializer (target_SML, isar_seri_sml)
  2196   add_serializer (target_SML, isar_seri_sml)
  2197   #> add_serializer (target_OCaml, isar_seri_ocaml)
  2197   #> add_serializer (target_OCaml, isar_seri_ocaml)
  2198   #> add_serializer (target_Haskell, isar_seri_haskell)
  2198   #> add_serializer (target_Haskell, isar_seri_haskell)
  2199   #> add_serializer (target_diag, fn _ => fn _=> fn _ => seri_diagnosis)
  2199   #> add_serializer (target_diag, fn _ => fn _=> fn _ => seri_diagnosis)
  2200   #> add_syntax_tyco "SML" "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
  2200   #> add_syntax_tyco "SML" "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
  2201       (gen_brackify (case fxy of NOBR => false | _ => eval_fxy (INFX (1, R)) fxy) o Pretty.breaks) [
  2201       (gen_brackify (case fxy of NOBR => false | _ => fixity (INFX (1, R)) fxy) o Pretty.breaks) [
  2202         pr_typ (INFX (1, X)) ty1,
  2202         pr_typ (INFX (1, X)) ty1,
  2203         str "->",
  2203         str "->",
  2204         pr_typ (INFX (1, R)) ty2
  2204         pr_typ (INFX (1, R)) ty2
  2205       ]))
  2205       ]))
  2206   #> add_syntax_tyco "OCaml" "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
  2206   #> add_syntax_tyco "OCaml" "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
  2207       (gen_brackify (case fxy of NOBR => false | _ => eval_fxy (INFX (1, R)) fxy) o Pretty.breaks) [
  2207       (gen_brackify (case fxy of NOBR => false | _ => fixity (INFX (1, R)) fxy) o Pretty.breaks) [
  2208         pr_typ (INFX (1, X)) ty1,
  2208         pr_typ (INFX (1, X)) ty1,
  2209         str "->",
  2209         str "->",
  2210         pr_typ (INFX (1, R)) ty2
  2210         pr_typ (INFX (1, R)) ty2
  2211       ]))
  2211       ]))
  2212   #> add_syntax_tyco "Haskell" "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
  2212   #> add_syntax_tyco "Haskell" "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>