diff -r d91391a8705b -r 2c8caac48ade src/HOLCF/Fixrec.thy --- a/src/HOLCF/Fixrec.thy Sun Oct 21 14:21:45 2007 +0200 +++ b/src/HOLCF/Fixrec.thy Sun Oct 21 14:21:48 2007 +0200 @@ -21,11 +21,13 @@ fail :: "'a maybe" "fail \ Abs_maybe (sinl\ONE)" - return :: "'a \ 'a maybe" +constdefs + return :: "'a \ 'a maybe" where "return \ \ x. Abs_maybe (sinr\(up\x))" - maybe_when :: "'b \ ('a \ 'b) \ 'a maybe \ 'b::pcpo" - "maybe_when \ \ f r m. sscase\(\ x. f)\(fup\r)\(Rep_maybe m)" +definition + maybe_when :: "'b \ ('a \ 'b) \ 'a maybe \ 'b::pcpo" where + "maybe_when = (\ f r m. sscase\(\ x. f)\(fup\r)\(Rep_maybe m))" lemma maybeE: "\p = \ \ Q; p = fail \ Q; \x. p = return\x \ Q\ \ Q" @@ -57,14 +59,14 @@ cont_Abs_maybe Abs_maybe_inverse Rep_maybe_strict) translations - "case m of fail \ t1 | return\x \ t2" == "maybe_when\t1\(\ x. t2)\m" + "case m of fail \ t1 | return\x \ t2" == "CONST maybe_when\t1\(\ x. t2)\m" subsubsection {* Monadic bind operator *} -constdefs - bind :: "'a maybe \ ('a \ 'b maybe) \ 'b maybe" - "bind \ \ m f. case m of fail \ fail | return\x \ f\x" +definition + bind :: "'a maybe \ ('a \ 'b maybe) \ 'b maybe" where + "bind = (\ m f. case m of fail \ fail | return\x \ f\x)" text {* monad laws *} @@ -86,9 +88,9 @@ subsubsection {* Run operator *} -constdefs - run:: "'a maybe \ 'a::pcpo" - "run \ maybe_when\\\ID" +definition + run:: "'a maybe \ 'a::pcpo" where + "run = maybe_when\\\ID" text {* rewrite rules for run *} @@ -103,12 +105,13 @@ subsubsection {* Monad plus operator *} -constdefs - mplus :: "'a maybe \ 'a maybe \ 'a maybe" - "mplus \ \ m1 m2. case m1 of fail \ m2 | return\x \ m1" +definition + mplus :: "'a maybe \ 'a maybe \ 'a maybe" where + "mplus = (\ m1 m2. case m1 of fail \ m2 | return\x \ m1)" -syntax "+++" :: "['a maybe, 'a maybe] \ 'a maybe" (infixr "+++" 65) -translations "m1 +++ m2" == "mplus\m1\m2" +abbreviation + mplus_syn :: "['a maybe, 'a maybe] \ 'a maybe" (infixr "+++" 65) where + "m1 +++ m2 == mplus\m1\m2" text {* rewrite rules for mplus *} @@ -129,14 +132,13 @@ subsubsection {* Fatbar combinator *} -constdefs - fatbar :: "('a \ 'b maybe) \ ('a \ 'b maybe) \ ('a \ 'b maybe)" - "fatbar \ \ a b x. a\x +++ b\x" +definition + fatbar :: "('a \ 'b maybe) \ ('a \ 'b maybe) \ ('a \ 'b maybe)" where + "fatbar = (\ a b x. a\x +++ b\x)" -syntax - "\" :: "['a \ 'b maybe, 'a \ 'b maybe] \ 'a \ 'b maybe" (infixr "\" 60) -translations - "m1 \ m2" == "fatbar\m1\m2" +abbreviation + fatbar_syn :: "['a \ 'b maybe, 'a \ 'b maybe] \ 'a \ 'b maybe" (infixr "\" 60) where + "m1 \ m2 == fatbar\m1\m2" lemma fatbar1: "m\x = \ \ (m \ ms)\x = \" by (simp add: fatbar_def) @@ -201,15 +203,15 @@ "_var" :: "'a" translations - "_Case1 p r" => "branch (_pat p)\(_var p r)" - "_var (_args x y) r" => "csplit\(_var x (_var y r))" - "_var () r" => "unit_when\r" + "_Case1 p r" => "CONST branch (_pat p)\(_var p r)" + "_var (_args x y) r" => "CONST csplit\(_var x (_var y r))" + "_var () r" => "CONST unit_when\r" parse_translation {* (* rewrites (_pat x) => (return) *) (* rewrites (_var x t) => (Abs_CFun (%x. t)) *) [("_pat", K (Syntax.const "Fixrec.return")), - mk_binder_tr ("_var", "Abs_CFun")]; + mk_binder_tr ("_var", @{const_syntax Abs_CFun})]; *} text {* Printing Case expressions *} @@ -219,14 +221,14 @@ print_translation {* let - fun dest_LAM (Const ("Rep_CFun",_) $ Const ("unit_when",_) $ t) = - (Syntax.const "Unity", t) - | dest_LAM (Const ("Rep_CFun",_) $ Const ("csplit",_) $ t) = + fun dest_LAM (Const (@{const_syntax Rep_CFun},_) $ Const (@{const_syntax unit_when},_) $ t) = + (Syntax.const @{const_syntax Unity}, t) + | dest_LAM (Const (@{const_syntax Rep_CFun},_) $ Const (@{const_syntax csplit},_) $ t) = let val (v1, t1) = dest_LAM t; val (v2, t2) = dest_LAM t1; in (Syntax.const "_args" $ v1 $ v2, t2) end - | dest_LAM (Const ("Abs_CFun",_) $ t) = + | dest_LAM (Const (@{const_syntax Abs_CFun},_) $ t) = let val abs = case t of Abs abs => abs | _ => ("x", dummyT, incr_boundvars 1 t $ Bound 0); @@ -234,11 +236,11 @@ in (Syntax.const "_var" $ x, t') end | dest_LAM _ = raise Match; (* too few vars: abort translation *) - fun Case1_tr' [Const("branch",_) $ p, r] = + fun Case1_tr' [Const(@{const_syntax branch},_) $ p, r] = let val (v, t) = dest_LAM r; in Syntax.const "_Case1" $ (Syntax.const "_match" $ p $ v) $ t end; - in [("Rep_CFun", Case1_tr')] end; + in [(@{const_syntax Rep_CFun}, Case1_tr')] end; *} translations @@ -249,67 +251,74 @@ types ('a, 'b) pat = "'a \ 'b maybe" -constdefs - cpair_pat :: "('a, 'c) pat \ ('b, 'd) pat \ ('a \ 'b, 'c \ 'd) pat" - "cpair_pat p1 p2 \ \\x, y\. - bind\(p1\x)\(\ a. bind\(p2\y)\(\ b. return\\a, b\))" +definition + cpair_pat :: "('a, 'c) pat \ ('b, 'd) pat \ ('a \ 'b, 'c \ 'd) pat" where + "cpair_pat p1 p2 = (\\x, y\. + bind\(p1\x)\(\ a. bind\(p2\y)\(\ b. return\\a, b\)))" +definition spair_pat :: - "('a, 'c) pat \ ('b, 'd) pat \ ('a::pcpo \ 'b::pcpo, 'c \ 'd) pat" - "spair_pat p1 p2 \ \(:x, y:). cpair_pat p1 p2\\x, y\" + "('a, 'c) pat \ ('b, 'd) pat \ ('a::pcpo \ 'b::pcpo, 'c \ 'd) pat" where + "spair_pat p1 p2 = (\(:x, y:). cpair_pat p1 p2\\x, y\)" - sinl_pat :: "('a, 'c) pat \ ('a::pcpo \ 'b::pcpo, 'c) pat" - "sinl_pat p \ sscase\p\(\ x. fail)" +definition + sinl_pat :: "('a, 'c) pat \ ('a::pcpo \ 'b::pcpo, 'c) pat" where + "sinl_pat p = sscase\p\(\ x. fail)" - sinr_pat :: "('b, 'c) pat \ ('a::pcpo \ 'b::pcpo, 'c) pat" - "sinr_pat p \ sscase\(\ x. fail)\p" +definition + sinr_pat :: "('b, 'c) pat \ ('a::pcpo \ 'b::pcpo, 'c) pat" where + "sinr_pat p = sscase\(\ x. fail)\p" - up_pat :: "('a, 'b) pat \ ('a u, 'b) pat" - "up_pat p \ fup\p" +definition + up_pat :: "('a, 'b) pat \ ('a u, 'b) pat" where + "up_pat p = fup\p" - TT_pat :: "(tr, unit) pat" - "TT_pat \ \ b. If b then return\() else fail fi" +definition + TT_pat :: "(tr, unit) pat" where + "TT_pat = (\ b. If b then return\() else fail fi)" - FF_pat :: "(tr, unit) pat" - "FF_pat \ \ b. If b then fail else return\() fi" +definition + FF_pat :: "(tr, unit) pat" where + "FF_pat = (\ b. If b then fail else return\() fi)" - ONE_pat :: "(one, unit) pat" - "ONE_pat \ \ ONE. return\()" +definition + ONE_pat :: "(one, unit) pat" where + "ONE_pat = (\ ONE. return\())" text {* Parse translations (patterns) *} translations - "_pat (cpair\x\y)" => "cpair_pat (_pat x) (_pat y)" - "_pat (spair\x\y)" => "spair_pat (_pat x) (_pat y)" - "_pat (sinl\x)" => "sinl_pat (_pat x)" - "_pat (sinr\x)" => "sinr_pat (_pat x)" - "_pat (up\x)" => "up_pat (_pat x)" - "_pat TT" => "TT_pat" - "_pat FF" => "FF_pat" - "_pat ONE" => "ONE_pat" + "_pat (CONST cpair\x\y)" => "CONST cpair_pat (_pat x) (_pat y)" + "_pat (CONST spair\x\y)" => "CONST spair_pat (_pat x) (_pat y)" + "_pat (CONST sinl\x)" => "CONST sinl_pat (_pat x)" + "_pat (CONST sinr\x)" => "CONST sinr_pat (_pat x)" + "_pat (CONST up\x)" => "CONST up_pat (_pat x)" + "_pat (CONST TT)" => "CONST TT_pat" + "_pat (CONST FF)" => "CONST FF_pat" + "_pat (CONST ONE)" => "CONST ONE_pat" text {* Parse translations (variables) *} translations - "_var (cpair\x\y) r" => "_var (_args x y) r" - "_var (spair\x\y) r" => "_var (_args x y) r" - "_var (sinl\x) r" => "_var x r" - "_var (sinr\x) r" => "_var x r" - "_var (up\x) r" => "_var x r" - "_var TT r" => "_var () r" - "_var FF r" => "_var () r" - "_var ONE r" => "_var () r" + "_var (CONST cpair\x\y) r" => "_var (_args x y) r" + "_var (CONST spair\x\y) r" => "_var (_args x y) r" + "_var (CONST sinl\x) r" => "_var x r" + "_var (CONST sinr\x) r" => "_var x r" + "_var (CONST up\x) r" => "_var x r" + "_var (CONST TT) r" => "_var () r" + "_var (CONST FF) r" => "_var () r" + "_var (CONST ONE) r" => "_var () r" text {* Print translations *} translations - "cpair\(_match p1 v1)\(_match p2 v2)" - <= "_match (cpair_pat p1 p2) (_args v1 v2)" - "spair\(_match p1 v1)\(_match p2 v2)" - <= "_match (spair_pat p1 p2) (_args v1 v2)" - "sinl\(_match p1 v1)" <= "_match (sinl_pat p1) v1" - "sinr\(_match p1 v1)" <= "_match (sinr_pat p1) v1" - "up\(_match p1 v1)" <= "_match (up_pat p1) v1" - "TT" <= "_match TT_pat ()" - "FF" <= "_match FF_pat ()" - "ONE" <= "_match ONE_pat ()" + "CONST cpair\(_match p1 v1)\(_match p2 v2)" + <= "_match (CONST cpair_pat p1 p2) (_args v1 v2)" + "CONST spair\(_match p1 v1)\(_match p2 v2)" + <= "_match (CONST spair_pat p1 p2) (_args v1 v2)" + "CONST sinl\(_match p1 v1)" <= "_match (CONST sinl_pat p1) v1" + "CONST sinr\(_match p1 v1)" <= "_match (CONST sinr_pat p1) v1" + "CONST up\(_match p1 v1)" <= "_match (CONST up_pat p1) v1" + "CONST TT" <= "_match (CONST TT_pat) ()" + "CONST FF" <= "_match (CONST FF_pat) ()" + "CONST ONE" <= "_match (CONST ONE_pat) ()" lemma cpair_pat1: "branch p\r\x = \ \ branch (cpair_pat p q)\(csplit\r)\\x, y\ = \" @@ -382,21 +391,23 @@ "_as_pat" :: "[idt, 'a] \ 'a" (infixr "\" 10) "_lazy_pat" :: "'a \ 'a" ("\ _" [1000] 1000) -constdefs - wild_pat :: "'a \ unit maybe" - "wild_pat \ \ x. return\()" +definition + wild_pat :: "'a \ unit maybe" where + "wild_pat = (\ x. return\())" - as_pat :: "('a \ 'b maybe) \ 'a \ ('a \ 'b) maybe" - "as_pat p \ \ x. bind\(p\x)\(\ a. return\\x, a\)" +definition + as_pat :: "('a \ 'b maybe) \ 'a \ ('a \ 'b) maybe" where + "as_pat p = (\ x. bind\(p\x)\(\ a. return\\x, a\))" - lazy_pat :: "('a \ 'b::pcpo maybe) \ ('a \ 'b maybe)" - "lazy_pat p \ \ x. return\(run\(p\x))" +definition + lazy_pat :: "('a \ 'b::pcpo maybe) \ ('a \ 'b maybe)" where + "lazy_pat p = (\ x. return\(run\(p\x)))" text {* Parse translations (patterns) *} translations - "_pat _" => "wild_pat" - "_pat (_as_pat x y)" => "as_pat (_pat y)" - "_pat (_lazy_pat x)" => "lazy_pat (_pat x)" + "_pat _" => "CONST wild_pat" + "_pat (_as_pat x y)" => "CONST as_pat (_pat y)" + "_pat (_lazy_pat x)" => "CONST lazy_pat (_pat x)" text {* Parse translations (variables) *} translations @@ -406,13 +417,13 @@ text {* Print translations *} translations - "_" <= "_match wild_pat ()" - "_as_pat x (_match p v)" <= "_match (as_pat p) (_args (_var x) v)" - "_lazy_pat (_match p v)" <= "_match (lazy_pat p) v" + "_" <= "_match (CONST wild_pat) ()" + "_as_pat x (_match p v)" <= "_match (CONST as_pat p) (_args (_var x) v)" + "_lazy_pat (_match p v)" <= "_match (CONST lazy_pat p) v" text {* Lazy patterns in lambda abstractions *} translations - "_cabs (_lazy_pat p) r" == "run oo (_Case1 (_lazy_pat p) r)" + "_cabs (_lazy_pat p) r" == "CONST run oo (_Case1 (_lazy_pat p) r)" lemma wild_pat [simp]: "branch wild_pat\(unit_when\r)\x = return\r" by (simp add: branch_def wild_pat_def) @@ -436,33 +447,41 @@ defaultsort pcpo -constdefs - match_UU :: "'a \ unit maybe" - "match_UU \ \ x. fail" +definition + match_UU :: "'a \ unit maybe" where + "match_UU = (\ x. fail)" + +definition + match_cpair :: "'a::cpo \ 'b::cpo \ ('a \ 'b) maybe" where + "match_cpair = csplit\(\ x y. return\)" - match_cpair :: "'a::cpo \ 'b::cpo \ ('a \ 'b) maybe" - "match_cpair \ csplit\(\ x y. return\)" +definition + match_spair :: "'a \ 'b \ ('a \ 'b) maybe" where + "match_spair = ssplit\(\ x y. return\)" - match_spair :: "'a \ 'b \ ('a \ 'b) maybe" - "match_spair \ ssplit\(\ x y. return\)" - - match_sinl :: "'a \ 'b \ 'a maybe" - "match_sinl \ sscase\return\(\ y. fail)" +definition + match_sinl :: "'a \ 'b \ 'a maybe" where + "match_sinl = sscase\return\(\ y. fail)" - match_sinr :: "'a \ 'b \ 'b maybe" - "match_sinr \ sscase\(\ x. fail)\return" +definition + match_sinr :: "'a \ 'b \ 'b maybe" where + "match_sinr = sscase\(\ x. fail)\return" - match_up :: "'a::cpo u \ 'a maybe" - "match_up \ fup\return" +definition + match_up :: "'a::cpo u \ 'a maybe" where + "match_up = fup\return" - match_ONE :: "one \ unit maybe" - "match_ONE \ \ ONE. return\()" +definition + match_ONE :: "one \ unit maybe" where + "match_ONE = (\ ONE. return\())" - match_TT :: "tr \ unit maybe" - "match_TT \ \ b. If b then return\() else fail fi" +definition + match_TT :: "tr \ unit maybe" where + "match_TT = (\ b. If b then return\() else fail fi)" - match_FF :: "tr \ unit maybe" - "match_FF \ \ b. If b then fail else return\() fi" +definition + match_FF :: "tr \ unit maybe" where + "match_FF = (\ b. If b then fail else return\() fi)" lemma match_UU_simps [simp]: "match_UU\x = fail" @@ -532,13 +551,6 @@ lemma ssubst_lhs: "\t = s; P s = Q\ \ P t = Q" by simp -ML {* -val cpair_equalI = thm "cpair_equalI"; -val cpair_eqD1 = thm "cpair_eqD1"; -val cpair_eqD2 = thm "cpair_eqD2"; -val ssubst_lhs = thm "ssubst_lhs"; -val branch_def = thm "branch_def"; -*} subsection {* Initializing the fixrec package *}