src/HOL/Library/code_test.ML
changeset 69593 3dda49e08b9d
parent 67330 2505cabfc515
child 69597 ff784d5a5bfb
equal deleted inserted replaced
69592:a80d8ec6c998 69593:3dda49e08b9d
    39 structure Code_Test: CODE_TEST =
    39 structure Code_Test: CODE_TEST =
    40 struct
    40 struct
    41 
    41 
    42 (* convert a list of terms into nested tuples and back *)
    42 (* convert a list of terms into nested tuples and back *)
    43 
    43 
    44 fun mk_tuples [] = @{term "()"}
    44 fun mk_tuples [] = \<^term>\<open>()\<close>
    45   | mk_tuples [t] = t
    45   | mk_tuples [t] = t
    46   | mk_tuples (t :: ts) = HOLogic.mk_prod (t, mk_tuples ts)
    46   | mk_tuples (t :: ts) = HOLogic.mk_prod (t, mk_tuples ts)
    47 
    47 
    48 fun dest_tuples (Const (@{const_name Pair}, _) $ l $ r) = l :: dest_tuples r
    48 fun dest_tuples (Const (\<^const_name>\<open>Pair\<close>, _) $ l $ r) = l :: dest_tuples r
    49   | dest_tuples t = [t]
    49   | dest_tuples t = [t]
    50 
    50 
    51 
    51 
    52 fun last_field sep str =
    52 fun last_field sep str =
    53   let
    53   let
   144   Pretty.blk (0, Pretty.fbreaks (map (pretty_failure ctxt target) failures))
   144   Pretty.blk (0, Pretty.fbreaks (map (pretty_failure ctxt target) failures))
   145 
   145 
   146 
   146 
   147 (* driver invocation *)
   147 (* driver invocation *)
   148 
   148 
   149 val overlord = Attrib.setup_config_bool @{binding "code_test_overlord"} (K false)
   149 val overlord = Attrib.setup_config_bool \<^binding>\<open>code_test_overlord\<close> (K false)
   150 
   150 
   151 fun with_overlord_dir name f =
   151 fun with_overlord_dir name f =
   152   let
   152   let
   153     val path =
   153     val path =
   154       Path.append (Path.explode "$ISABELLE_HOME_USER") (Path.basic (name ^ serial_string ()))
   154       Path.append (Path.explode "$ISABELLE_HOME_USER") (Path.basic (name ^ serial_string ()))
   172   in Exn.release (Code_Thingol.dynamic_value ctxt (Exn.map_res o postproc) evaluator t) end
   172   in Exn.release (Code_Thingol.dynamic_value ctxt (Exn.map_res o postproc) evaluator t) end
   173 
   173 
   174 
   174 
   175 (* term preprocessing *)
   175 (* term preprocessing *)
   176 
   176 
   177 fun add_eval (Const (@{const_name Trueprop}, _) $ t) = add_eval t
   177 fun add_eval (Const (\<^const_name>\<open>Trueprop\<close>, _) $ t) = add_eval t
   178   | add_eval (Const (@{const_name "HOL.eq"}, _) $ lhs $ rhs) = (fn acc =>
   178   | add_eval (Const (\<^const_name>\<open>HOL.eq\<close>, _) $ lhs $ rhs) = (fn acc =>
   179       acc
   179       acc
   180       |> add_eval rhs
   180       |> add_eval rhs
   181       |> add_eval lhs
   181       |> add_eval lhs
   182       |> cons rhs
   182       |> cons rhs
   183       |> cons lhs)
   183       |> cons lhs)
   184   | add_eval (Const (@{const_name "Not"}, _) $ t) = add_eval t
   184   | add_eval (Const (\<^const_name>\<open>Not\<close>, _) $ t) = add_eval t
   185   | add_eval (Const (@{const_name "Orderings.ord_class.less_eq"}, _) $ lhs $ rhs) = (fn acc =>
   185   | add_eval (Const (\<^const_name>\<open>Orderings.ord_class.less_eq\<close>, _) $ lhs $ rhs) = (fn acc =>
   186       lhs :: rhs :: acc)
   186       lhs :: rhs :: acc)
   187   | add_eval (Const (@{const_name "Orderings.ord_class.less"}, _) $ lhs $ rhs) = (fn acc =>
   187   | add_eval (Const (\<^const_name>\<open>Orderings.ord_class.less\<close>, _) $ lhs $ rhs) = (fn acc =>
   188       lhs :: rhs :: acc)
   188       lhs :: rhs :: acc)
   189   | add_eval _ = I
   189   | add_eval _ = I
   190 
   190 
   191 fun mk_term_of [] = @{term "None :: (unit \<Rightarrow> yxml_of_term) option"}
   191 fun mk_term_of [] = \<^term>\<open>None :: (unit \<Rightarrow> yxml_of_term) option\<close>
   192   | mk_term_of ts =
   192   | mk_term_of ts =
   193       let
   193       let
   194         val tuple = mk_tuples ts
   194         val tuple = mk_tuples ts
   195         val T = fastype_of tuple
   195         val T = fastype_of tuple
   196       in
   196       in
   197         @{term "Some :: (unit \<Rightarrow> yxml_of_term) \<Rightarrow> (unit \<Rightarrow> yxml_of_term) option"} $
   197         \<^term>\<open>Some :: (unit \<Rightarrow> yxml_of_term) \<Rightarrow> (unit \<Rightarrow> yxml_of_term) option\<close> $
   198           (absdummy @{typ unit} (@{const yxml_string_of_term} $
   198           (absdummy \<^typ>\<open>unit\<close> (@{const yxml_string_of_term} $
   199             (Const (@{const_name Code_Evaluation.term_of}, T --> @{typ term}) $ tuple)))
   199             (Const (\<^const_name>\<open>Code_Evaluation.term_of\<close>, T --> \<^typ>\<open>term\<close>) $ tuple)))
   200       end
   200       end
   201 
   201 
   202 fun test_terms ctxt ts target =
   202 fun test_terms ctxt ts target =
   203   let
   203   let
   204     val thy = Proof_Context.theory_of ctxt
   204     val thy = Proof_Context.theory_of ctxt
   205 
   205 
   206     fun term_of t = Sign.of_sort thy (fastype_of t, @{sort term_of})
   206     fun term_of t = Sign.of_sort thy (fastype_of t, \<^sort>\<open>term_of\<close>)
   207 
   207 
   208     fun ensure_bool t =
   208     fun ensure_bool t =
   209       (case fastype_of t of
   209       (case fastype_of t of
   210         @{typ bool} => ()
   210         \<^typ>\<open>bool\<close> => ()
   211       | _ =>
   211       | _ =>
   212         error (Pretty.string_of
   212         error (Pretty.string_of
   213           (Pretty.block [Pretty.str "Test case not of type bool:", Pretty.brk 1,
   213           (Pretty.block [Pretty.str "Test case not of type bool:", Pretty.brk 1,
   214             Syntax.pretty_term ctxt t])))
   214             Syntax.pretty_term ctxt t])))
   215 
   215 
   217 
   217 
   218     val evals = map (fn t => filter term_of (add_eval t [])) ts
   218     val evals = map (fn t => filter term_of (add_eval t [])) ts
   219     val eval = map mk_term_of evals
   219     val eval = map mk_term_of evals
   220 
   220 
   221     val t =
   221     val t =
   222       HOLogic.mk_list @{typ "bool \<times> (unit \<Rightarrow> yxml_of_term) option"}
   222       HOLogic.mk_list \<^typ>\<open>bool \<times> (unit \<Rightarrow> yxml_of_term) option\<close>
   223         (map HOLogic.mk_prod (ts ~~ eval))
   223         (map HOLogic.mk_prod (ts ~~ eval))
   224 
   224 
   225     val result = dynamic_value_strict ctxt t target
   225     val result = dynamic_value_strict ctxt t target
   226 
   226 
   227     val failed =
   227     val failed =
   259           (Pretty.block (Pretty.str "Term contains free variables:" :: Pretty.brk 1 ::
   259           (Pretty.block (Pretty.str "Term contains free variables:" :: Pretty.brk 1 ::
   260             Pretty.commas (map (pretty_free ctxt) frees))))
   260             Pretty.commas (map (pretty_free ctxt) frees))))
   261 
   261 
   262     val T = fastype_of t
   262     val T = fastype_of t
   263     val _ =
   263     val _ =
   264       if Sign.of_sort (Proof_Context.theory_of ctxt) (T, @{sort term_of}) then ()
   264       if Sign.of_sort (Proof_Context.theory_of ctxt) (T, \<^sort>\<open>term_of\<close>) then ()
   265       else error ("Type " ^ Syntax.string_of_typ ctxt T ^
   265       else error ("Type " ^ Syntax.string_of_typ ctxt T ^
   266        " of term not of sort " ^ Syntax.string_of_sort ctxt @{sort term_of})
   266        " of term not of sort " ^ Syntax.string_of_sort ctxt \<^sort>\<open>term_of\<close>)
   267 
   267 
   268     val t' =
   268     val t' =
   269       HOLogic.mk_list @{typ "bool \<times> (unit \<Rightarrow> yxml_of_term) option"}
   269       HOLogic.mk_list \<^typ>\<open>bool \<times> (unit \<Rightarrow> yxml_of_term) option\<close>
   270         [HOLogic.mk_prod (@{term "False"}, mk_term_of [t])]
   270         [HOLogic.mk_prod (\<^term>\<open>False\<close>, mk_term_of [t])]
   271 
   271 
   272     val result = dynamic_value_strict ctxt t' target
   272     val result = dynamic_value_strict ctxt t' target
   273   in (case result of [(_, SOME [t])] => t | _ => error "Evaluation failed") end
   273   in (case result of [(_, SOME [t])] => t | _ => error "Evaluation failed") end
   274 
   274 
   275 
   275 
   482 (* driver for GHC *)
   482 (* driver for GHC *)
   483 
   483 
   484 val ghcN = "GHC"
   484 val ghcN = "GHC"
   485 val ISABELLE_GHC = "ISABELLE_GHC"
   485 val ISABELLE_GHC = "ISABELLE_GHC"
   486 
   486 
   487 val ghc_options = Attrib.setup_config_string @{binding code_test_ghc} (K "")
   487 val ghc_options = Attrib.setup_config_string \<^binding>\<open>code_test_ghc\<close> (K "")
   488 
   488 
   489 fun mk_driver_ghc ctxt path modules value_name =
   489 fun mk_driver_ghc ctxt path modules value_name =
   490   let
   490   let
   491     val driverN = "Main.hs"
   491     val driverN = "Main.hs"
   492 
   492 
   571 
   571 
   572 
   572 
   573 (* command setup *)
   573 (* command setup *)
   574 
   574 
   575 val _ =
   575 val _ =
   576   Outer_Syntax.command @{command_keyword test_code}
   576   Outer_Syntax.command \<^command_keyword>\<open>test_code\<close>
   577     "compile test cases to target languages, execute them and report results"
   577     "compile test cases to target languages, execute them and report results"
   578       (Scan.repeat1 Parse.prop -- (@{keyword "in"} |-- Scan.repeat1 Parse.name)
   578       (Scan.repeat1 Parse.prop -- (\<^keyword>\<open>in\<close> |-- Scan.repeat1 Parse.name)
   579         >> (fn (ts, targets) => Toplevel.keep (test_code_cmd ts targets o Toplevel.context_of)))
   579         >> (fn (ts, targets) => Toplevel.keep (test_code_cmd ts targets o Toplevel.context_of)))
   580 
   580 
   581 val target_Scala = "Scala_eval"
   581 val target_Scala = "Scala_eval"
   582 val target_Haskell = "Haskell_eval"
   582 val target_Haskell = "Haskell_eval"
   583 
   583