* Re: Q: camlp4 use?
2000-01-14 20:42 ` Markus Mottl
@ 2000-01-20 16:15 ` Anton Moscal
2000-01-25 8:22 ` Gerard Huet
1 sibling, 0 replies; 6+ messages in thread
From: Anton Moscal @ 2000-01-20 16:15 UTC (permalink / raw)
To: Markus Mottl; +Cc: OCAML
On Fri, 14 Jan 2000, Markus Mottl wrote:
> > I use CamlP4 for different for of the "syntaxic sugaring" (for example -
> > for list comprehension syntax) and for incapsulations of some patterns in
> > matching.
>
> This sounds interesting! List comprehensions would definitely be a neat
> thing to have in OCaml. Would you mind explaining more about this? How
> does this look like in the code and how is it implemented?
code looks like the following:
let my_map fn list = [fn x | x <- list]
yet another example:
| (Seq (p, p')), toks ->
[(Rcat (r, r'), tail') |
(r, tail) <- parse p toks; (r', tail') <- parse p' tail
]
instead of using bool expression at the right side of '|', I
use `when' in the pattern matching (this is bad choice, but I'm too lazy
for good implemetation). Also this construction can be used with array
types: for iteration through array elements instead of `<-' should be used
'<-|', and if we want to get array as result - [| |] instead of []. For
example:
let array_of_list l = [| x | x <- l |]
let list_of_array v = [ x | x <-| v ]
Implementation wasn't works very fast, but when efficinecy are really
important I use "usual" ML notation.
Regards,
Anton Moscal
This is the text for camlp4. This text also contains other syntax sugar
(such as local types and open declaration, some support for lazy lists
etc), and send "as is". Use it on your own risk:
======================================================
open Stdpp
open Pcaml
type strictness = Strict | Lazy | Vector
let rec is_irrefut_patt =
function
| <:patt< $lid:_$ >> -> true
| <:patt< () >> -> true
| <:patt< _ >> -> true
| <:patt< ($x$ as $_$) >> -> is_irrefut_patt x
| <:patt< { $list:fpl$ } >> ->
List.for_all (fun (_, p) -> is_irrefut_patt p) fpl
| <:patt< ($p$ : $_$) >> -> is_irrefut_patt p
| <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl
| _ -> false
let compr loc out is gbl_str =
let gen_patt_fun p whn expr default =
match (whn, is_irrefut_patt p) with
| None, true -> <:expr< fun acc $p$ -> $expr$ >>
| _, _ -> <:expr< fun acc -> fun [$list:[p,whn,expr; <:patt<_>>,None,<:expr<acc>>]$ ] >>
in
let empty_list = match gbl_str with
| Vector
| Strict -> <:expr< [] >>
| Lazy -> <:expr<lazy Seq.Nil>>
in
let (_, inp, _, str) = List.hd is in
let gen_fold fn acc inp = function
| Lazy -> <:expr<Seq .fold $fn$ $acc$ $inp$>>
| Vector -> <:expr<Array.fold_left $fn$ $acc$ $inp$>>
| Strict -> <:expr<List .fold_left $fn$ $acc$ $inp$>>
in
let rec gen_fun = function
| ((p, inp, whn, str)::tail) ->
begin let cons a b =
match gbl_str with
| Lazy -> <:expr<lazy Seq.Cons $a$ $b$>>
| Strict
| Vector -> <:expr< [$a$::$b$] >>
in
let acc = <:expr<acc>> in
match tail with
| [] ->
gen_patt_fun p whn (cons (List.hd out) acc) acc
| (_,inp', _, str)::_ ->
gen_patt_fun p whn (gen_fold (gen_fun tail) acc inp' str) acc
end
| _ ->
failwith "Syn.gen_fun"
in
let rev_res = <:expr< $gen_fold (gen_fun is) empty_list inp str$ >> in
match gbl_str with
| Strict -> <:expr< List.rev $rev_res$ >>
| Vector -> <:expr< Array.of_list (List.rev $rev_res$) >>
| Lazy -> <:expr< Seq .rev $rev_res$ >>
let mklistexp loc last =
let rec loop top =
function
[] ->
(match last with
Some e -> e
| None -> <:expr< [] >> )
| e1 :: el ->
<:expr< [$e1$ :: $loop False el$] >>
in loop True
let is_str_type =
Grammar.Entry.of_parser gram "operator" (fun strm ->
match Stream.peek strm with
| Some ("", "type")
| Some ("", "open")
| Some ("", "class")
| Some ("", "external")
| Some ("", "exception") -> ()
| _ -> raise Stream.Failure
)
let _ = Gramext.warning_verbose := false
EXTEND
GLOBAL: expr str_item patt let_binding ctyp;
patt: BEFORE "simple" [ "ref" [LIDENT "ref"; p = patt LEVEL "simple" -> <:patt< { contents = $p$ } >> ]];
whn: [["when"; cond = expr LEVEL "expr1" -> cond]];
item: [[ p = patt; "<-?"; inp = expr LEVEL "expr1"; whn = OPT whn -> (p, inp, whn, Lazy )
| p = patt; "<-|"; inp = expr LEVEL "expr1"; whn = OPT whn -> (p, inp, whn, Vector)
| p = patt; "<-" ; inp = expr LEVEL "expr1"; whn = OPT whn -> (p, inp, whn, Strict)
]];
expr1_semi_list:
[ [ e = expr LEVEL "expr1"; ";"; el = expr1_semi_list -> e :: el
| e = expr LEVEL "expr1"; ";" -> [e]
| e = expr LEVEL "expr1" -> [e] ] ]
;
expr: LEVEL "simple"
[[ "["; "]" -> <:expr< [] >>
| "["; el = expr1_semi_list; inp = ["]" -> None | "|"; is = LIST1 item SEP ";"; "]" -> Some is] -> (
match inp with
| None -> <:expr< $mklistexp loc None el$ >>
| Some is -> compr loc el is Strict
)
| "[|"; "|]" -> <:expr< [| |] >>
| "[|"; el = expr1_semi_list; inp = ["|]" -> None | "|"; is = LIST1 item SEP ";"; "|]" -> Some is] -> (
match inp with
| None -> <:expr< [| $list:el$ |] >>
| Some is -> compr loc el is Vector
)
| "["; "?"; "?"; "]" -> <:expr<lazy Seq.Nil>>
| "["; "?"; el = expr1_semi_list; inp = ["?"; "]" -> None | "|"; is = LIST1 item SEP ";"; "?"; "]" -> Some is] -> (
match inp with
| None ->
List.fold_right (fun item acc ->
<:expr<lazy (Seq.Cons ($item$, $acc$))>>) el <:expr<lazy Seq.Nil>>
| Some is -> compr loc el is Lazy
)
]];
(*
expr: LEVEL "simple" [[ "nest"; name = STRING ->
let chan = open_in name in
let old_name = !input_file in
input_file := name;
let res =
try
Grammar.Entry.parse expr (Stream.of_channel chan)
with
ex -> close_in chan; input_file := old_name; raise ex
in
close_in chan;
input_file := old_name;
res
]];
*)
expr: LEVEL "top"
[ LEFTA
[ e = SELF; "where"; rf = OPT "rec"; lbs = LIST1 let_binding SEP "and" ->
let recf = match rf with Some _ -> true | None -> false in
<:expr< let $rec:recf$ $list:lbs$ in $e$ >> ]
];
expr: LEVEL "expr1"
[["let"; is_str_type; s = str_item; "in"; e = expr LEVEL "top" ->
<:expr< let module M_M_temp = struct $s$; value _res = $e$; end in M_M_temp._res >>
]];
(*
expr: LEVEL "expr1"
[[
"let"; "open"; m = UIDENT; "in"; e = expr LEVEL "top" ->
<:expr< let module M_M_temp = struct open $[m]$; value _res = $e$; end in M_M_temp._res >>]
| ["let_mod"; si = str_item; "in"; e = expr LEVEL "top" ->
<:expr< let module M_M_temp = struct $si$; value _res = $e$; end in M_M_temp._res >>
] ];
*)
patt: LAST
[ LEFTA [l = patt; "@@"; v = patt -> <:patt< ($l$, $v$) >>] ];
str_item: [[ "infix"; op = LIDENT; op' = OPT ["="; op' = LIDENT -> op'] ->
let op' = match op' with None -> op | Some op' -> op' in
EXTEND GLOBAL: expr;
expr: LEVEL "*" [[ a = expr; $op$; b = expr -> <:expr< $lid:op'$ $a$ $b$ >> ]];
END; <:str_item< () >>
]];
expr: BEFORE "+" [ "//" RIGHTA [ hd = expr; "//"; tl = expr -> <:expr<lazy (Seq.Cons ($hd$, $tl$))>> ]];
END;;
let _ = Gramext.warning_verbose := true
EXTEND
expr: LEVEL "*" [[ a = expr; "o"; b = expr -> <:expr< Common.compose $a$ $b$ >> ]];
expr: LEVEL "**" [[ a = expr; "$"; b = expr -> <:expr< Common.compose $b$ $a$ >> ]];
expr: LEVEL "+" [[ a = expr; "++"; b = expr -> <:expr< Seq.cat $b$ $a$ >> ]];
END;;
(*
EXTEND
GLOBAL: expr;
expr: LEVEL "simple" [[ "[<"; e = expr; ">]" -> <:expr< Tk'.eval $e$ >> ]];
expr: LEVEL "simple" [[ "{<"; e = expr; ">}" -> <:expr< Tk'.cback (fun args -> $e$) >> ]];
END
*)
======================================================
^ permalink raw reply [flat|nested] 6+ messages in thread