type ('n, 't) symbol =
    NT of 'n
  | T of 't
  | Error

type ('n, 't) production = P of 'n * (('n, 't) symbol list)

type 'attrib attribution = 'attrib list -> 'attrib

type ('n, 't, 'attrib) rule =
    { production : ('n, 't) production;
      attribution : 'attrib attribution
    }

type ('n, 't, 'attrib) grammar =
    { nonterminals : 'n list;
      terminals : 't list;
      rules : ('n, 't, 'attrib) rule list;
      start : 'n
    }

(* List utilities *)

let rec truncate k l =
  match l with
    [] -> []
  | x::xs ->
      if k = 0
      then []
      else x::(truncate (k - 1) xs)

let rec append_truncate k l1 l2 =
  if k = 0
  then []
  else
    match l1 with
      [] -> truncate k l2
    | x::xs -> x :: (append_truncate (k - 1) xs l2)

let filter pred l =
  let rec f l r =
    match l with
      [] -> List.rev r
    | x::xs ->
	if pred x 
	then f xs (x::r)
	else f xs r
  in f l []

let pair_map f l1 l2 =
  let rec loop_1 l1 =
    match l1 with
      [] -> []
    | x::xs ->
	let rec loop_2 l2 =
	  match l2 with
	    [] -> loop_1 xs
	  | y::ys -> (f x y) :: loop_2 ys
	in loop_2 l2
  in loop_1 l1

let union l1 l2 =
  let rec loop add result =
    match add with
      [] -> result
    | x::xs ->
	loop
	  xs
	  (if List.mem x result then result else x::result)
  in loop l1 l2

let union_list l = List.fold_left union [] l

let uniq l =
  let rec loop l r =
    match l with
      [] -> List.rev r
    | x::xs -> loop xs (if List.mem x r then r else x::r)
  in loop l []

let pair_map f l1 l2 =
  let rec loop_1 l1 =
    match l1 with
      [] -> []
    | x::xs ->
	let rec loop_2 l2 =
	  match l2 with
	    [] -> loop_1 xs
	  | y::ys -> (f x y) :: loop_2 ys
	in loop_2 l2
  in loop_1 l1

(* Grammar access *)

let nonterminals g = g.nonterminals
let terminals g = g.terminals
let rules g = g.rules
let start g = g.start

let rule_production r = r.production
let rule_lhs r =
  match r.production with P(lhs, _) -> lhs
let rule_rhs r =
  match r.production with P(_, rhs) -> rhs
let rule_attribution r = r.attribution
  
let rules_with_lhs g n =
  filter (function rule -> rule_lhs rule = n) g.rules