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