Re: Q: camlp4 use?

[Anton Moscal <msk@post.tepkom.ru>]

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
*)
======================================================