(** The parametrized version of the node type *)
type 'a node' = 
  | NTerm   of 'tr * 'a nCommon' 
  | NInt    of 'ir * 'a nCommon' * int64 option ref
  | NStr    of 'sr * 'a nCommon' * string option ref
  | NAggr   of 'ar * 'a nCommon' * 'a node' list ref
  | NChoice of 'cr * 'a nCommon' * 'a node' option ref
  | NList   of 'lr * 'a nCommon' * 'a node' list ref
  constraint 'a = <term:'tr; int:'ir; str:'sr; aggr:'ar; choice:'cr; list:'lr>

(** Common attributes of nodes are collected in this record *)
and 'a nCommon' = {
  parent : 'a node' option ref;
  myself : 'a node';
} constraint 'a = <term:'tr; int:'ir; str:'sr; aggr:'ar; choice:'cr; list:'lr>

(** All the different kinds of rules follow. *)

(** This abstract base class gathers common functionality of rules *)
class virtual abstractRule (name:string) =
object (self)
  method name = name
end
and virtual rules = object
    (self : <term:termRule; int:intRule; str:strRule; aggr:aggrRule;
             choice:choiceRule; list:listRule; ..>)
end
(** Terminal rules *)
and termRule name =
object (self)
  inherit abstractRule name
  method kind = "terminalRule"
  method to_string = name ^ "."
  method makeTermNode (parent : rules node' option) =
    let rec n = NTerm ((self :> termRule), {parent=ref parent; myself=n})
    in n
end
(** Integer rules *)
and intRule name =
object (self)
  inherit abstractRule name
  method kind = "integerRule"
  method to_string = name ^ " =^= INTEGER."
  method makeIntNode (parent : rules node' option) int_opt =
    let rec n = NInt ((self :> intRule), {parent=ref parent; myself=n},
                      ref int_opt)
    in n
end
(** String rules *)
and strRule name =
object (self)
  inherit abstractRule name
  method kind = "stringRule"
  method to_string = name ^ " =^= STRING."
  method makeStrNode (parent : rules node' option) str_opt =
    let rec n = NStr ((self :> strRule), {parent=ref parent; myself=n},
                      ref str_opt)
    in n
end
(** Aggregate rules *)
and aggrRule name =
object (self)
  inherit abstractRule name
  method kind = "aggregateRule"
  val mutable parts = ([] : abstractRule list)
  method parts = parts
  method initParts parts' = parts <- parts'
  method to_string = name ^ " =^= "
    ^ (String.concat "; " (List.map (fun p -> p#name) parts)) ^ "."
  method makeAggrNode (parent : rules node' option) kid_list =
    let rec n = NAggr ((self :> aggrRule), {parent=ref parent; myself=n},
                       ref kid_list)
    in n
end
(** Choice rules *)
and choiceRule name =
object (self)
  inherit abstractRule name
  method kind = "choiceRule"
  val mutable alts = ([] : abstractRule list)
  method alts = alts
  method initAlts alts' = alts <- alts'
  method to_string = name ^ " =^= " 
    ^ (String.concat " | " (List.map (fun a -> a#name) alts)) ^ "."
  method makeChoiceNode (parent : rules node' option) kid_opt =
    let rec n = NChoice ((self :> choiceRule), {parent=ref parent; 
                                                myself=n},
                         ref kid_opt)
    in n
end
(** List rules *)
and listRule name =
object (self)
  inherit abstractRule name
  method kind = "listRule"
  val mutable item = (None : abstractRule option)
  method item : abstractRule option = item
  method initItem item' = item <- Some item'
  method to_string = name ^ " =^= (" ^ 
    (match item with None -> "<NOT-YET-DEFINED>" | Some i -> i#name) 
    ^ ")*."
  method makeListNode (parent : rules node' option) kid_list =
    let rec n = NList ((self :> listRule), {parent=ref parent; myself=n},
                       ref kid_list)
    in n
end

(* Finally shorter types *)
type node = rules node'
type nCommon = rules nCommon'


(*** Re mutable rule fields  ***)

(* This is how I end up generating grammars at runtime. *)
(* Simple Test Grammar for plus/times expressions *)
  let exp = new choiceRule "exp"
  let intLit = new intRule "intLit"
  let binExp = new aggrRule "binExp"
  let binOp = new choiceRule "binOp"
  let plusOp = new termRule "plusOp"
  let timesOp = new termRule "timesOp"
  let startrule = exp;;
  exp#initAlts [
    (intLit :> abstractRule);
    (binExp :> abstractRule);
  ];;
  binExp#initParts[
    (exp :> abstractRule);
    (binOp :> abstractRule);
    (exp :> abstractRule)
  ];;
  binOp#initAlts [
    (plusOp :> abstractRule);
    (timesOp :> abstractRule);
  ];;


(*** Re parent ref cell in nCommon ***)

(* Simple Test Tree for the expression with the int litereral "0" *)

(* This is how I intended to write it but it does not compile due to
   "This kind of expression is not allowed as right-hand side of `let rec'" 
   which is interesting since it does not contain a new statement. *)

(*
let rec t = exp#makeChoiceNode None
  (Some (intLit#makeIntNode (Some t)
           (Some (Int64.of_int 3))));;
*)

(* The tree can be generated and later fixed like this, 
   but this requires parent refs: *)

let t = exp#makeChoiceNode None
  (Some (intLit#makeIntNode None
           (Some (Int64.of_int 3))));;

(* helpers for fixParents below *)
let common = function
    | NTerm   (_,c)
    | NInt    (_,c,_)
    | NStr    (_,c,_)
    | NAggr   (_,c,_)
    | NChoice (_,c,_)
    | NList   (_,c,_) -> c
let kids = function
    | NTerm   (_,_)
    | NInt    (_,_,_)
    | NStr    (_,_,_)
    | NChoice (_,_,{contents=None}) -> []
    | NChoice (_,_,{contents=Some k}) -> [k]
    | NAggr   (_,_,{contents=ks})
    | NList   (_,_,{contents=ks}) -> ks

let rec fixParents (p:node option) (n:node) =
  (common n).parent := p;
  List.iter (fun k -> fixParents (Some n) k) (kids n);;

fixParents None t;;

(* I guess this is how it should be done.  
   No need to put parent in a ref if trees can always be defined like this: *)

let rec (t:node) = 
  NChoice (exp, {parent=ref None; myself=t}, (ref (Some (
    let rec (i:node) = 
      NInt (intLit, {parent=ref (Some t); myself=i}, ref (Some (
        Int64.of_int 0)))
    in i))));;