(** The parametrized version of the node type *)
type 'a node_desc = 
  | NTerm   of 'tr 
  | NInt    of 'ir * int64 option ref
  | NStr    of 'sr * string option ref
  | NAggr   of 'ar * 'a node' list ref
  | NChoice of 'cr * 'a node' option ref
  | NList   of 'lr * '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 node' = {
  desc : 'a node_desc;
  mutable parent : 'a node' option;
} 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) =
    {desc = NTerm(self :> termRule); parent = parent}
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 =
    {desc = NInt ((self :> intRule), ref int_opt); parent = parent}
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 =
    {desc = NStr ((self :> strRule), ref str_opt); parent = parent}
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 =
    {desc = NAggr ((self :> aggrRule), ref kid_list); parent = parent}
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 =
    {desc = NChoice ((self :> choiceRule), ref kid_opt); parent = parent}
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 =
    {desc = NList ((self :> listRule), ref kid_list); parent = parent}
end

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

(*** 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 kids node =
  match node.desc with
  | 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) =
  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) = 
  {desc = NChoice
     (exp,
      ref(Some{desc = NInt (intLit, ref(Some(Int64.of_int 0)));
               parent = Some t}));
   parent = None};;