(** Framework for trees built according to a tree grammar
 * 
 * Here tree grammars can have rules of six different kinds:
 * - Terminal rules which correspond to empty leaf nodes
 *   Ex:  trule
 * - Integer rules which correspond to leaf nodes containing an integer
 *   Ex:  irule = INTEGER
 * - String rules which correspond to leaf nodes containing a string
 *   Ex:  srule = STRING
 * - Aggregate rules which correspond to nodes that have a fixed number
 *   of child nodes.  Children are ordered and their corresponding rules
 *   are given in the aggregate rule.
 *   Ex:  arule = rule1 rule2 ... ruleN
 * - Choice rules which correspond to nodes that have one child which
 *   has a corresponding rule as given by the choice rule.
 *   Ex:  crule = rule1 | rule2 | ... | ruleN
 * - List rules which correspond to nodes that have zero or more children
 *   of a given rule.
 *   Ex:  lrule = rule*
 *
 * This framework is written so that grammars (ie sets of rules) can
 * be easily changed or even generated at runtime.  An actual rules is
 * an objects of one of the classes representing the above six kinds
 * of rules.  Rules and visitors are implemented as objects for best
 * code reuse.
 *
 * All this is relatively close to dealing with ASTs except that the
 * grammar is not static.
 * 
 *)

(** We need to parametrize the node type with all rule classes in
    order to work around the fact that OCaml does not support mutually
    recusive definitions of types and classes.  Eeech! *)

(** The parametrized version of the node type *)
type ('tr,'ir,'sr,'ar,'cr,'lr) node' = 
  | NTerm   of 'tr *  ('tr,'ir,'sr,'ar,'cr,'lr) nCommon' 
  | NInt    of 'ir *  ('tr,'ir,'sr,'ar,'cr,'lr) nCommon' 
      * int64 option ref
  | NStr    of 'sr *  ('tr,'ir,'sr,'ar,'cr,'lr) nCommon' 
      * string option ref
  | NAggr   of 'ar *  ('tr,'ir,'sr,'ar,'cr,'lr) nCommon' 
      * ('tr,'ir,'sr,'ar,'cr,'lr) node' list ref
  | NChoice of 'cr *  ('tr,'ir,'sr,'ar,'cr,'lr) nCommon' 
      * ('tr,'ir,'sr,'ar,'cr,'lr) node' option ref
  | NList   of 'lr *  ('tr,'ir,'sr,'ar,'cr,'lr) nCommon' 
      * ('tr,'ir,'sr,'ar,'cr,'lr) node' list ref

(** Common attributes of nodes are collected in this record *)
and  ('tr,'ir,'sr,'ar,'cr,'lr) nCommon' = {
  parent : ('tr,'ir,'sr,'ar,'cr,'lr) node' option ref;
  myself : ('tr,'ir,'sr,'ar,'cr,'lr) node';
}

(** 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
(** Terminal rules *)
and termRule name =
object (self)
  inherit abstractRule name
  method kind = "terminalRule"
  method to_string = name ^ "."
  method makeTermNode 
    (parent : (termRule,intRule,strRule,aggrRule,choiceRule,listRule) 
       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 : (termRule,intRule,strRule,aggrRule,choiceRule,listRule) 
       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 : (termRule,intRule,strRule,aggrRule,choiceRule,listRule) 
       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 : (termRule,intRule,strRule,aggrRule,choiceRule,listRule) 
       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 : (termRule,intRule,strRule,aggrRule,choiceRule,listRule) 
       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 : (termRule,intRule,strRule,aggrRule,choiceRule,listRule) 
       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 = 
    (termRule,intRule,strRule,aggrRule,choiceRule,listRule) node'
type nCommon = 
    (termRule,intRule,strRule,aggrRule,choiceRule,listRule) nCommon'


class type ['baton] visitorIface =
object
  method visitTermNode 
    : termRule -> nCommon -> 'baton -> 'baton 
  method visitIntNode 
    : intRule -> nCommon -> int64 option -> 'baton -> 'baton 
  method visitStrNode 
    :  strRule -> nCommon -> string option -> 'baton -> 'baton 
  method visitAggrNode 
    : aggrRule -> nCommon -> node list -> 'baton -> 'baton
  method visitChoiceNode 
    : choiceRule -> nCommon -> node option -> 'baton -> 'baton
  method visitListNode 
    : listRule -> nCommon -> node list -> 'baton -> 'baton
end

let accept (n:node) (v:'baton visitorIface) (b:'baton) =
  match n with
    | NTerm   (tr,c)    -> v#visitTermNode   tr c     b
    | NInt    (ir,c,io) -> v#visitIntNode    ir c !io b
    | NStr    (sr,c,so) -> v#visitStrNode    sr c !so b
    | NAggr   (ar,c,ks) -> v#visitAggrNode   ar c !ks b
    | NChoice (cr,c,ko) -> v#visitChoiceNode cr c !ko b
    | NList   (lr,c,ks) -> v#visitListNode   lr c !ks b


class ['baton] defaultVisitor =
object (self : 'baton #visitorIface)
  method visitTermNode   r c    b = b
  method visitIntNode    r c io b = b
  method visitStrNode    r c so b = b
  method visitAggrNode   r c kl b =
    List.fold_left
      (fun b k -> accept k (self :> _ defaultVisitor) b)
      b kl
  method visitChoiceNode r c ko b =
    match ko with
        None -> b
      | Some k -> accept k (self :> _ defaultVisitor) b
  method visitListNode   r c kl b =
    List.fold_left
      (fun b k -> accept k (self :> _ defaultVisitor) b)
      b kl
end

class summingVisitor =
object 
  inherit [int64] defaultVisitor
  method visitIntNode _ _ io b =
    match io with
        None -> b (* treat no integer as 0 *)
      | Some i -> Int64.add b i
end


class printingVisitor out =
object (self : _ #visitorIface)
  inherit [_] defaultVisitor as super
  method private indline out s indent=
    for i=0 to indent-1 do output_string out "  " done;
    output_string out (s ^ "\n")
  method visitTermNode r _ (ind,limit) =
    if limit = 0 then output_string out "...\n"
    else self#indline out ("terminal: " ^ r#name) ind;
    (ind,limit)
  method visitIntNode r _ io (ind,limit) =
    if limit = 0 then output_string out "...\n"
    else self#indline out ("integer: " ^ r#name ^ " " ^ match io with 
                          None -> "<UNINITIALIZED-INT>"
                        | Some i -> (Int64.to_string i)) 
      ind;
    (ind,limit)
  method visitAggrNode r c ks (ind,limit) =
    if limit = 0 
    then begin output_string out "...\n"; (ind,limit) end
    else begin self#indline out ("aggregate: " ^ r#name) ind;
      super#visitAggrNode r c ks(ind+1,limit-1) end
  method visitChoiceNode r c ko (ind,limit) =
    if limit = 0 
    then begin output_string out "...\n"; (ind,limit) end
    else begin self#indline out ("choice: " ^ r#name) ind;
      super#visitChoiceNode r c ko (ind+1,limit-1) end
  method visitListNode r c ks (ind,limit) =
    if limit = 0 
    then begin output_string out "...\n"; (ind,limit) end
    else begin self#indline out ("aggregate: " ^ r#name) ind;
      super#visitListNode r c ks(ind+1,limit-1) end
end