src/HOL/Library/Code_Message.thy
author haftmann
Thu, 26 Jun 2008 10:07:01 +0200
changeset 27368 9f90ac19e32b
parent 25673 35a6c1b1c8e3
child 27487 c8a6ce181805
permissions -rw-r--r--
established Plain theory and image
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
24999
haftmann
parents:
diff changeset
     1
(*  ID:         $Id$
haftmann
parents:
diff changeset
     2
    Author:     Florian Haftmann, TU Muenchen
haftmann
parents:
diff changeset
     3
*)
haftmann
parents:
diff changeset
     4
haftmann
parents:
diff changeset
     5
header {* Monolithic strings (message strings) for code generation *}
haftmann
parents:
diff changeset
     6
haftmann
parents:
diff changeset
     7
theory Code_Message
27368
9f90ac19e32b established Plain theory and image
haftmann
parents: 25673
diff changeset
     8
imports Plain List
24999
haftmann
parents:
diff changeset
     9
begin
haftmann
parents:
diff changeset
    10
haftmann
parents:
diff changeset
    11
subsection {* Datatype of messages *}
haftmann
parents:
diff changeset
    12
haftmann
parents:
diff changeset
    13
datatype message_string = STR string
haftmann
parents:
diff changeset
    14
haftmann
parents:
diff changeset
    15
lemmas [code func del] = message_string.recs message_string.cases
haftmann
parents:
diff changeset
    16
haftmann
parents:
diff changeset
    17
lemma [code func]: "size (s\<Colon>message_string) = 0"
haftmann
parents:
diff changeset
    18
  by (cases s) simp_all
haftmann
parents:
diff changeset
    19
25673
35a6c1b1c8e3 Added code lemma for message_string_size.
berghofe
parents: 24999
diff changeset
    20
lemma [code func]: "message_string_size (s\<Colon>message_string) = 0"
35a6c1b1c8e3 Added code lemma for message_string_size.
berghofe
parents: 24999
diff changeset
    21
  by (cases s) simp_all
35a6c1b1c8e3 Added code lemma for message_string_size.
berghofe
parents: 24999
diff changeset
    22
24999
haftmann
parents:
diff changeset
    23
subsection {* ML interface *}
haftmann
parents:
diff changeset
    24
haftmann
parents:
diff changeset
    25
ML {*
haftmann
parents:
diff changeset
    26
structure Message_String =
haftmann
parents:
diff changeset
    27
struct
haftmann
parents:
diff changeset
    28
haftmann
parents:
diff changeset
    29
fun mk s = @{term STR} $ HOLogic.mk_string s;
haftmann
parents:
diff changeset
    30
haftmann
parents:
diff changeset
    31
end;
haftmann
parents:
diff changeset
    32
*}
haftmann
parents:
diff changeset
    33
haftmann
parents:
diff changeset
    34
haftmann
parents:
diff changeset
    35
subsection {* Code serialization *}
haftmann
parents:
diff changeset
    36
haftmann
parents:
diff changeset
    37
code_type message_string
haftmann
parents:
diff changeset
    38
  (SML "string")
haftmann
parents:
diff changeset
    39
  (OCaml "string")
haftmann
parents:
diff changeset
    40
  (Haskell "String")
haftmann
parents:
diff changeset
    41
haftmann
parents:
diff changeset
    42
setup {*
haftmann
parents:
diff changeset
    43
let
haftmann
parents:
diff changeset
    44
  val charr = @{const_name Char}
haftmann
parents:
diff changeset
    45
  val nibbles = [@{const_name Nibble0}, @{const_name Nibble1},
haftmann
parents:
diff changeset
    46
    @{const_name Nibble2}, @{const_name Nibble3},
haftmann
parents:
diff changeset
    47
    @{const_name Nibble4}, @{const_name Nibble5},
haftmann
parents:
diff changeset
    48
    @{const_name Nibble6}, @{const_name Nibble7},
haftmann
parents:
diff changeset
    49
    @{const_name Nibble8}, @{const_name Nibble9},
haftmann
parents:
diff changeset
    50
    @{const_name NibbleA}, @{const_name NibbleB},
haftmann
parents:
diff changeset
    51
    @{const_name NibbleC}, @{const_name NibbleD},
haftmann
parents:
diff changeset
    52
    @{const_name NibbleE}, @{const_name NibbleF}];
haftmann
parents:
diff changeset
    53
in
haftmann
parents:
diff changeset
    54
  fold (fn target => CodeTarget.add_pretty_message target
haftmann
parents:
diff changeset
    55
    charr nibbles @{const_name Nil} @{const_name Cons} @{const_name STR})
haftmann
parents:
diff changeset
    56
  ["SML", "OCaml", "Haskell"]
haftmann
parents:
diff changeset
    57
end
haftmann
parents:
diff changeset
    58
*}
haftmann
parents:
diff changeset
    59
haftmann
parents:
diff changeset
    60
code_reserved SML string
haftmann
parents:
diff changeset
    61
code_reserved OCaml string
haftmann
parents:
diff changeset
    62
haftmann
parents:
diff changeset
    63
code_instance message_string :: eq
haftmann
parents:
diff changeset
    64
  (Haskell -)
haftmann
parents:
diff changeset
    65
haftmann
parents:
diff changeset
    66
code_const "op = \<Colon> message_string \<Rightarrow> message_string \<Rightarrow> bool"
haftmann
parents:
diff changeset
    67
  (SML "!((_ : string) = _)")
haftmann
parents:
diff changeset
    68
  (OCaml "!((_ : string) = _)")
haftmann
parents:
diff changeset
    69
  (Haskell infixl 4 "==")
haftmann
parents:
diff changeset
    70
haftmann
parents:
diff changeset
    71
end