(* camlp4 front-end for a simplified make(1) language
   copyright (C) 2002 Graydon Hoare <graydon@pobox.com> 
   GPL 2.x + no warranty provided or implied *)

(* construct a new Pcaml grammar entry yielding a MLast.str_item *)

open List

let makefile : MLast.str_item Grammar.Entry.e = 
  Grammar.Entry.create Pcaml.gram "makefile"

(* generate a new lexer from our ocamllex function *)

let makefile_lexer =  { Token.func = (Token.lexer_func_of_ocamllex 
					Mlex.token);
			Token.using = (fun _ -> ());
			Token.removing = (fun _ -> ());
			Token.tparse = (fun _ -> None);
			Token.text = Token.lexer_text }

(* clear out existing camlp4 ocaml grammar entries *)

let _ =
  begin
    Pcaml.no_constructors_arity := true; 
    Grammar.Unsafe.reinit_gram Pcaml.gram (makefile_lexer);
    Grammar.Unsafe.clear_entry Pcaml.interf;
    Grammar.Unsafe.clear_entry Pcaml.implem;
    Grammar.Unsafe.clear_entry Pcaml.top_phrase;
    Grammar.Unsafe.clear_entry Pcaml.use_file;
    Grammar.Unsafe.clear_entry Pcaml.module_type;
    Grammar.Unsafe.clear_entry Pcaml.module_expr;
    Grammar.Unsafe.clear_entry Pcaml.sig_item;
    Grammar.Unsafe.clear_entry Pcaml.str_item;
    Grammar.Unsafe.clear_entry Pcaml.expr;
    Grammar.Unsafe.clear_entry Pcaml.patt;
    Grammar.Unsafe.clear_entry Pcaml.ctyp;
    Grammar.Unsafe.clear_entry Pcaml.let_binding;
    Grammar.Unsafe.clear_entry Pcaml.class_type;
    Grammar.Unsafe.clear_entry Pcaml.class_expr;
    Grammar.Unsafe.clear_entry Pcaml.class_sig_item;
    Grammar.Unsafe.clear_entry Pcaml.class_str_item
  end

(* helper: build a list AST node out of a list of AST nodes *)

let mk_list vals loc =
  let rec loop v =    
    match v with 
	x::xs -> (<:expr< [ $x$ :: $loop xs$ ] >>)
      | [] -> (<:expr< [] >>)
  in
    loop vals

(* helper: pull maybes out of list *)
let some xs =
  let t = ref [] in
    iter (function None -> () | Some x -> t := x :: !t) xs;
    rev !t

type item = ASSIGN | RULE

(* describe makefiles *)

EXTEND

GLOBAL: Pcaml.implem makefile;

Pcaml.implem:
  [ [ res = makefile -> ([(res, loc)], false) ] ];
  
makefile:
  [ [ maybe_items = LIST0 makefile_item; EOF -> 
        let items = some maybe_items in
	let rule_p (_, _, x) = match x with RULE -> true | ASSIGN -> false in
        let (rules, assigns) = partition rule_p items in
        let dead_rule = (<:patt< x >>, None, <:expr< Mk.Rule (x, [], []) >>) in
        let live_rules = map (fun (n,_,_) -> 
            (<:patt< $str:n$ >> , None, <:expr< $lid:n$ () >>)) rules 
        in
        let resz = live_rules @ [dead_rule] in
        let resolver = (<:patt< resolve >>, <:expr< fun [ $list:resz$ ] >>) in
        let bind (n, e, _) = let pwel = [<:patt< _ >>, None, e] in
            <:patt<  $lid:n$ >> , <:expr< fun [$list:pwel$] >> 
        in
        let r_binds = map bind rules in
        let a_binds = map bind assigns in
        let funs = resolver :: (a_binds @ r_binds) in
        let (top,_,_) = hd rules in
        let tree = <:expr< let rec $list:funs$ in $lid:top$ () >> in
        let entry = [( <:patt< _ >>, <:expr< Be.trans $tree$ >> )] in
        let recur = false in
        let items = [ <:str_item< value $rec:recur$ $list:entry$ >> ] in
          <:str_item< declare $list:items$ end >> ] ];

makefile_item:
  [ 
    [ EOL -> None
    | s = WORD; "="; ws = words; EOL -> Some (s, <:expr< $ws$ >>, ASSIGN)

    | t = WORD; ":"; ws = words; EOL; a = actions -> 
	let ex = <:expr< 
		 let targ = $str:t$ in
		 let dep_names = $ws$ in
		 let deps = List.map resolve dep_names in
		 let actions = $a$ in
		   Mk.Rule (targ, deps, actions) 
		   >>
	in Some (t,ex, RULE) ]
  ];
 

actions:
  [ [ az = LIST0 action -> (mk_list az loc) ]  ];

action: 
  [ [ TAB; ws = words; EOL -> <:expr< String.concat " " $ws$ >> ] ];


words:
  [ [ ws = LIST0 word -> (let ls = mk_list ws loc in <:expr< List.flatten $ls$ >>) ] ];

word: 
  [ 
    [ w = WORD -> <:expr< [$str:w$] >> 
    | "$"; "^" -> <:expr< dep_names >>
    | "$"; "<" -> <:expr< [List.hd dep_names] >>
    | "$"; "@" -> <:expr< [targ] >>
    | "$"; "("; w = WORD; ")" -> <:expr< ($lid:w$ ()) >> ]
  ];

END
;;