src/HOLCF/domain/syntax.ML
author wenzelm
Thu Jul 14 19:28:24 2005 +0200 (2005-07-14)
changeset 16842 5979c46853d1
parent 16394 495dbcd4f4c9
child 17811 10ebcd7032c1
permissions -rw-r--r--
tuned;
oheimb@2453
     1
(*  Title:      HOLCF/domain/syntax.ML
oheimb@2445
     2
    ID:         $Id$
wenzelm@12030
     3
    Author:     David von Oheimb
oheimb@2445
     4
wenzelm@12030
     5
Syntax generator for domain section.
regensbu@1274
     6
*)
regensbu@1274
     7
regensbu@1274
     8
structure Domain_Syntax = struct 
regensbu@1274
     9
regensbu@1274
    10
local 
regensbu@1274
    11
regensbu@1274
    12
open Domain_Library;
oheimb@4122
    13
infixr 5 -->; infixr 6 ->>;
oheimb@4122
    14
fun calc_syntax dtypeprod ((dname, typevars), 
huffman@16394
    15
	(cons': (string * mixfix * (bool*string option*typ) list) list)) =
regensbu@1274
    16
let
oheimb@4122
    17
(* ----- constants concerning the isomorphism ------------------------------- *)
regensbu@1274
    18
regensbu@1274
    19
local
oheimb@4122
    20
  fun opt_lazy (lazy,_,t) = if lazy then mk_uT t else t
oheimb@4122
    21
  fun prod     (_,_,args) = if args = [] then oneT
oheimb@4122
    22
			    else foldr' mk_sprodT (map opt_lazy args);
oheimb@4122
    23
  fun freetvar s = let val tvar = mk_TFree s in
oheimb@4122
    24
		   if tvar mem typevars then freetvar ("t"^s) else tvar end;
skalberg@15574
    25
  fun when_type (_   ,_,args) = foldr (op ->>) (freetvar "t") (map third args);
regensbu@1274
    26
in
regensbu@1274
    27
  val dtype  = Type(dname,typevars);
oheimb@4122
    28
  val dtype2 = foldr' mk_ssumT (map prod cons');
oheimb@4008
    29
  val dnam = Sign.base_name dname;
oheimb@4122
    30
  val const_rep  = (dnam^"_rep" ,              dtype  ->> dtype2, NoSyn);
oheimb@4122
    31
  val const_abs  = (dnam^"_abs" ,              dtype2 ->> dtype , NoSyn);
skalberg@15574
    32
  val const_when = (dnam^"_when",foldr (op ->>) (dtype ->> freetvar "t") (map when_type cons'), NoSyn);
oheimb@4122
    33
  val const_copy = (dnam^"_copy", dtypeprod ->> dtype  ->> dtype , NoSyn);
regensbu@1274
    34
end;
regensbu@1274
    35
oheimb@4122
    36
(* ----- constants concerning constructors, discriminators, and selectors --- *)
regensbu@1274
    37
regensbu@1274
    38
local
regensbu@1274
    39
  val escape = let
oheimb@4122
    40
	fun esc (c::cs) = if c mem ["'","_","(",")","/"] then "'"::c::esc cs
oheimb@4122
    41
							 else      c::esc cs
oheimb@4122
    42
	|   esc []      = []
wenzelm@4709
    43
	in implode o esc o Symbol.explode end;
skalberg@15574
    44
  fun con (name,s,args) = (name,foldr (op ->>) dtype (map third args),s);
oheimb@4122
    45
  fun dis (con ,s,_   ) = (dis_name_ con, dtype->>trT,
wenzelm@5700
    46
			   Mixfix(escape ("is_" ^ con), [], Syntax.max_pri));
oheimb@4122
    47
			(* stricly speaking, these constants have one argument,
oheimb@4122
    48
			   but the mixfix (without arguments) is introduced only
oheimb@4122
    49
			   to generate parse rules for non-alphanumeric names*)
huffman@16224
    50
  fun mat (con ,s,args) = (mat_name_ con, dtype->>mk_ssumT(oneT,mk_uT(mk_ctupleT(map third args))),
huffman@16224
    51
			   Mixfix(escape ("match_" ^ con), [], Syntax.max_pri));
huffman@16394
    52
  fun sel1 (_,sel,typ)  = Option.map (fn s => (s,dtype ->> typ,NoSyn)) sel;
huffman@16394
    53
  fun sel (_   ,_,args) = List.mapPartial sel1 args;
regensbu@1274
    54
in
regensbu@1274
    55
  val consts_con = map con cons';
regensbu@1274
    56
  val consts_dis = map dis cons';
huffman@16224
    57
  val consts_mat = map mat cons';
skalberg@15570
    58
  val consts_sel = List.concat(map sel cons');
regensbu@1274
    59
end;
regensbu@1274
    60
oheimb@4122
    61
(* ----- constants concerning induction ------------------------------------- *)
regensbu@1274
    62
oheimb@4122
    63
  val const_take   = (dnam^"_take"  , HOLogic.natT-->dtype->>dtype, NoSyn);
oheimb@4122
    64
  val const_finite = (dnam^"_finite", dtype-->HOLogic.boolT       , NoSyn);
regensbu@1274
    65
oheimb@4122
    66
(* ----- case translation --------------------------------------------------- *)
regensbu@1274
    67
regensbu@1274
    68
local open Syntax in
regensbu@1274
    69
  val case_trans = let 
oheimb@4122
    70
	fun c_ast con mx = Constant (const_name con mx);
oheimb@4122
    71
	fun expvar n     = Variable ("e"^(string_of_int n));
oheimb@4122
    72
	fun argvar n m _ = Variable ("a"^(string_of_int n)^"_"^
oheimb@4122
    73
					 (string_of_int m));
oheimb@1637
    74
	fun app s (l,r)   = mk_appl (Constant s) [l,r];
wenzelm@9060
    75
	fun case1 n (con,mx,args) = mk_appl (Constant "_case1")
skalberg@15570
    76
		 [Library.foldl (app "Rep_CFun") (c_ast con mx, (mapn (argvar n) 1 args)),
oheimb@1637
    77
		  expvar n];
oheimb@1637
    78
	fun arg1 n (con,_,args) = if args = [] then expvar n 
oheimb@1637
    79
				  else mk_appl (Constant "LAM ") 
oheimb@1637
    80
		 [foldr' (app "_idts") (mapn (argvar n) 1 args) , expvar n];
wenzelm@3534
    81
  in
wenzelm@3534
    82
    ParsePrintRule
wenzelm@9060
    83
      (mk_appl (Constant "_case_syntax") [Variable "x", foldr'
wenzelm@9060
    84
				(fn (c,cs) => mk_appl (Constant"_case2") [c,cs])
wenzelm@3534
    85
				 (mapn case1 1 cons')],
skalberg@15570
    86
       mk_appl (Constant "Rep_CFun") [Library.foldl 
slotosch@5291
    87
				(fn (w,a ) => mk_appl (Constant"Rep_CFun" ) [w,a ])
oheimb@4008
    88
				 (Constant (dnam^"_when"),mapn arg1 1 cons'),
wenzelm@3534
    89
				 Variable "x"])
regensbu@1274
    90
  end;
regensbu@1274
    91
end;
regensbu@1274
    92
regensbu@1274
    93
in ([const_rep, const_abs, const_when, const_copy] @ 
huffman@16224
    94
     consts_con @ consts_dis @ consts_mat @ consts_sel @
regensbu@1274
    95
    [const_take, const_finite],
regensbu@1274
    96
    [case_trans])
regensbu@1274
    97
end; (* let *)
regensbu@1274
    98
oheimb@4122
    99
(* ----- putting all the syntax stuff together ------------------------------ *)
regensbu@1274
   100
regensbu@1274
   101
in (* local *)
regensbu@1274
   102
oheimb@4008
   103
fun add_syntax (comp_dnam,eqs': ((string * typ list) *
huffman@16394
   104
	(string * mixfix * (bool*string option*typ) list) list) list) thy'' =
regensbu@1274
   105
let
oheimb@4122
   106
  val dtypes  = map (Type o fst) eqs';
oheimb@4122
   107
  val boolT   = HOLogic.boolT;
wenzelm@16842
   108
  val funprod = foldr' HOLogic.mk_prodT (map (fn tp => tp ->> tp          ) dtypes);
wenzelm@16842
   109
  val relprod = foldr' HOLogic.mk_prodT (map (fn tp => tp --> tp --> boolT) dtypes);
oheimb@4122
   110
  val const_copy   = (comp_dnam^"_copy"  ,funprod ->> funprod, NoSyn);
oheimb@4122
   111
  val const_bisim  = (comp_dnam^"_bisim" ,relprod --> boolT  , NoSyn);
regensbu@1274
   112
  val ctt           = map (calc_syntax funprod) eqs';
skalberg@15570
   113
in thy'' |> ContConsts.add_consts_i (List.concat (map fst ctt) @ 
oheimb@4122
   114
				    (if length eqs'>1 then [const_copy] else[])@
oheimb@4122
   115
				    [const_bisim])
skalberg@15570
   116
	 |> Theory.add_trrules_i (List.concat(map snd ctt))
regensbu@1274
   117
end; (* let *)
regensbu@1274
   118
regensbu@1274
   119
end; (* local *)
regensbu@1274
   120
end; (* struct *)