I tried to implement the optimizations for list comprehensions
as stated in the book by simon peyton jones (1987). The problem
of using fresh variables I circumvented in an admittedly `ugly' way,
however (which is not fool proof since there could be programmers
that use variable names like __h__0, __h__1, ...).

The Starting point was the file Camlp4ListComprehension.ml from
camlp4.

Any comments are wellcome.

cheers

christian

Here is the code
-------------------------------------------------------------------------
open Camlp4;;

module Id = struct
 let name =    "ListComprehension";;
 let version = "$Id: ListComprehension";;
end

module Make (Syntax : Sig.Camlp4Syntax) = struct

open Sig;;
include Syntax;;

let rec safe_nth n = function
 | [] -> None
 | [(x,_)] -> if n = 1 then Some x else None
 | _ :: l -> safe_nth (n - 1) l
;;

let stream_peek_nth n s = safe_nth n (Stream.npeek n s);;

let lc_generator = Gram.Entry.of_parser "lc_generator" (fun s ->
 let rec skip_patt n = match stream_peek_nth n s with
  | Some (KEYWORD "<-") -> n
  | Some (KEYWORD ("[" | "[<")) -> skip_patt (ignore_upto "]" (n + 1) + 1)
  | Some (KEYWORD "(") -> skip_patt (ignore_upto ")" (n + 1) + 1)
  | Some (KEYWORD "{") -> skip_patt (ignore_upto "}" (n + 1) + 1)
  | Some (KEYWORD ("as" | "::" | ";" | "," | "_"))
  | Some (LIDENT _ | UIDENT _) -> skip_patt (n + 1)
  | Some _ | None -> raise Stream.Failure
 and ignore_upto end_kwd n = match stream_peek_nth n s with
  | Some (KEYWORD prm) when prm = end_kwd -> n 
  | Some (KEYWORD ("[" | "[<")) -> ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1)
  | Some (KEYWORD "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1)
  | Some (KEYWORD "{") -> ignore_upto end_kwd (ignore_upto "}" (n + 1) + 1)
  | Some _ -> ignore_upto end_kwd (n + 1)
  | None -> raise Stream.Failure
 in skip_patt 1
);;

let var = ref 0;;
let fresh () = incr var; !var;;

let rec compr _loc e acc = function
 | [] -> <:expr< $e$::$acc$ >>
 | `filter b :: qs -> <:expr< if $b$ then $compr _loc e acc qs$ else $acc$ >>
 | `gen (p, l1) :: qs ->
 let h  = Format.sprintf "__h__%i" (fresh ()) in
 let u  = Format.sprintf "__u__%i" (fresh ()) in
 let us = Format.sprintf "__us__%i" (fresh ()) in
 <:expr<
  let rec $lid:h$ = function
   | [] -> $acc$
   | $lid:u$ :: $lid:us$ -> $if Ast.is_irrefut_patt p then
    <:expr< (fun $p$ -> $compr _loc e <:expr< ($lid:h$ $lid:us$) >> qs$) $lid:u$ >>
   else
    <:expr<
     (function $p$ ->
      $compr _loc e <:expr< ($lid:h$ $lid:us$) >> qs$ | _ -> $lid:h$ $lid:us$) $lid:u$
    >>
   $
  in $lid:h$ $l1$
 >>
 | _ -> <:expr< [] >>
;;

let list_comprehension = Gram.Entry.mk "list_comprehension";;

DELETE_RULE Gram expr: "["; sem_expr_for_list; "]" END;;

EXTEND Gram
 GLOBAL: expr list_comprehension;
 expr: LEVEL "simple" [
  [ "["; e = list_comprehension; "]" -> e]
 ];
 list_comprehension: [
  [ e = expr LEVEL "top"; ";"; mk = sem_expr_for_list ->
   <:expr< $e$::$mk <:expr< [] >>$ >>
  | e = expr LEVEL "top"; ";" -> <:expr< [$e$] >>
  | e = expr LEVEL "top"; "|"; l = LIST1 quantifier SEP ";" ->
   compr _loc e <:expr< [] >> l
  | e = expr LEVEL "top" -> <:expr< [$e$] >> ]
 ];
 quantifier: [
  [ lc_generator; p = patt; "<-"; e = expr LEVEL "top" -> `gen (p, e)
  | e = expr LEVEL "top" -> `filter e ]
 ];
END;;

end

let module M = Register.OCamlSyntaxExtension Id Make in ();;
-------------------------------------------------------------------------
On Tue, Jan 22, 2008 at 02:42:00PM +0100, Nicolas Pouillard wrote:
> Excerpts from christian.sternagel's message of Tue Jan 22 14:33:55 +0100 2008:
> > > > How about the transformation from Chapter 7 of [1] (by Philip Wadler)?
> > > > It should be similar to the `pseudo code':
> > > > 
> > > > type expr = ...;;
> > > > type patt = ...;;
> > > > type qualifier = Gen of patt * expr | Filt of expr;;
> > > > type compr = (expr * qualifier list);;
> > > > let rec expr = function
> > > >  | ...
> > > >  | (e, qs) -> transform [] (e, qs)
> > > >  | ...
> > > > and transform l = function
> > > >  | (e, []) -> expr e :: expr l
> > > >  | (e, Filt f :: qs) -> if expr f then transform l (e, qs) else expr l
> > > >  | (e, Gen (p, l1) :: qs) ->
> > > >   let rec h = function
> > > >    | [] -> expr l
> > > >    | u :: us -> (function p -> transform (h us) (e, qs) | _ -> h us) u
> > > >   in h (expr l1)
> > > > ;;
> > > > 
> > > > (* where h, u, us are fresh variables not occurring in e, l1, l, or qs *)
> > > > 
> > > > Sorry I'm not yet familiar with camlp4 grammar extensions, but of course
> > > > above code would make use of them otherwise.
> > > 
> > > Yes this approach can be integrated with a camlp4 extension.
> > > 
> > > > It is stated in [1] that the resulting code is optimal in that it
> > > > performs the minimum number of cons operations.
> > > 
> > > Nice.
> > > 
> > > > And I did ignore the hint that fresh variables make things
> > > > complicated :).
> > > 
> > > Yes it can...
> > > 
> > > Best regards,
> > > 
> > > -- 
> > > Nicolas Pouillard aka Ertai
> > > 
> > I deduce that there is no standard way of introducing
> > `fresh' (w.r.t. the abstract syntax tree) variables
> > within a camlp4 syntax extension? Wouldn't that be nice? =)
> > 
> 
> That  would be nice, but doing it cleanly would require a large amount of work
> and user visible changes.
> 
> -- 
> Nicolas Pouillard aka Ertai