using Nemerle.Compiler
using Fx7.UtilMacrosHelper

set namespace Fx7

module UtilMacrosHelper
  public CreateMemento (tb : TypeBuilder) : void
    def fields = tb.GetMembers ().FoldLeft ([], fun (mem, acc) {
      match (mem) {
        | m is IField 
          when m.GetModifiers ().GetMacroAttributes ().Exists (_ is <[ Copy ]>) =>
          m :: acc
        | _ => 
          acc
      }
    })

    def tname = Parsetree.PExpr.FromQualifiedIdentifier (tb.Manager, tb.FullName)

    def memento =
      tb.DefineNestedType (
        <[ decl:
           private class Memento {
             internal mutable next_memento : $tname.Memento;
           }
         ]>)
    foreach (f in fields)
      memento.Define (<[ decl: internal mutable $(f.Name : dyn) : $(f.GetMemType () : typed); ]>)
    memento.Compile ()

    tb.Define (<[ decl: mutable memento : $tname.Memento ]>)

    def names = fields.Map (_.Name)
    tb.Define (
      <[ decl: 
        SaveMemento () : void
        {
          def b = $tname.Memento ();
          {.. $(names.Map (fun (n) {
            <[ b.$(n : dyn) = this.$(n : dyn) ]>
          })) }
          b.next_memento = this.memento;
          this.memento = b;
        }
      ]>)

    tb.Define (
      <[ decl: 
        RestoreMemento () : void
        {
          def b = memento;
          memento = b.next_memento;
          {.. $(names.Map (fun (n) {
            <[ this.$(n : dyn) = b.$(n : dyn) ]>
          })) }
        }
      ]>)


[Nemerle.MacroUsage (Nemerle.MacroPhase.WithTypedMembers,
                     Nemerle.MacroTargets.Field)] \
macro Copy (_ : TypeBuilder, _ : FieldBuilder)
  {}

[Nemerle.MacroUsage (Nemerle.MacroPhase.WithTypedMembers,
                     Nemerle.MacroTargets.Class)] \
macro Rollbackable (tb : TypeBuilder)
  tb.Define (<[ decl: [Copy] mutable current_level : int ]>)
  CreateMemento (tb)

  tb.Define (
    <[ decl: 
      public WillWrite () : void
      {
        when (pool.current_level != current_level) {
          pool.QueueRollback (this);
          SaveMemento ();
          current_level = pool.current_level;
        } 
      }
    ]>)

  tb.Define (
    <[ decl: 
      public Rollback () : void
      {
        assert (memento.current_level <= pool.current_level);
        RestoreMemento ();
      }
    ]>)

[Nemerle.MacroUsage (Nemerle.MacroPhase.WithTypedMembers,
                     Nemerle.MacroTargets.Class)] \
macro CreateMemento (tb : TypeBuilder)
  CreateMemento (tb)


[Nemerle.MacroUsage (Nemerle.MacroPhase.BeforeInheritance,
                     Nemerle.MacroTargets.Field)] \
macro AutoStats (_ : TypeBuilder, f : ParsedField)
  f.modifiers.mods |= NemerleAttributes.Internal | NemerleAttributes.Mutable

[Nemerle.MacroUsage (Nemerle.MacroPhase.WithTypedMembers,
                     Nemerle.MacroTargets.Method)] \
macro AutoStats (tb : TypeBuilder, mb : MethodBuilder)
  def fields = tb.GetMembers ().FoldLeft ([], fun (mem, acc) {
    match (mem) {
      | m is IField when m.GetModifiers ().GetMacroAttributes ().Exists (_ is <[ AutoStats ]>) =>
        m :: acc
      | _ => 
        acc
    }
  })
  def fields = fields.Sort (fun (x, y) { x.Location.CompareTo (y.Location) })
  def names = $[ <[ ($(f.Name : string), $(f.Name : dyn).ToString ()) ]> | f in fields ]
  mb.Body = <[ [ .. $names ] ]>

  match (tb.LookupMember ("StatsRec"))
    | [rec is TypeBuilder] =>
      rec.Define (<[ decl: internal mutable tsc : long ]>)
      rec.Define (<[ decl: internal parent : $(tb.Name : dyn) ]>)

      def make = rec.DefineAndReturn (<[ decl:
        public MakeDelta () : void
        {
          tsc = Core.read_tsc () - tsc
        }
      ]>) :> MethodBuilder

      def save = rec.DefineAndReturn (<[ decl:
        public SaveNow () : void
        {
          tsc = Core.read_tsc ()
        }
      ]>) :> MethodBuilder

      rec.Define (<[ decl:
        public this (par : $(tb.Name : dyn))
        {
          parent = par;
          SaveNow ();
        }
      ]>)
      
      foreach (f in fields)
        rec.Define (<[ decl: internal mutable $(f.Name : dyn) : $(f.GetMemType () : typed) ]>)
        save.Body = <[ $(save.Body); 
          this.$(f.Name : dyn) = parent.$(f.Name : dyn) ]>
        make.Body = <[ $(make.Body); 
          this.$(f.Name : dyn) = parent.$(f.Name : dyn) - this.$(f.Name : dyn) ]>

      rec.Compile ()

    | _ => assert (false)


[Nemerle.MacroUsage (Nemerle.MacroPhase.BeforeInheritance,
                     Nemerle.MacroTargets.Field)] \
macro Option (_ : TypeBuilder, f : ParsedField, params _args : array [expr])
  f.modifiers.mods |= NemerleAttributes.Internal | NemerleAttributes.Static | NemerleAttributes.Mutable

[Nemerle.MacroUsage (Nemerle.MacroPhase.WithTypedMembers,
                     Nemerle.MacroTargets.Field)] \
macro Option (tb : TypeBuilder, f : FieldBuilder, params args : array [expr])
  mutable desc = "No description"
  mutable saliases = []
  mutable aliases = []
  foreach (a in args)
    | <[ $(d : string) ]> => 
      unless (d == "") desc = d
    | <[ $(n : dyn) ]> =>
      saliases ::= n
      aliases ::= <[ $(n : string) ]>
    | _ => assert (false)
  def aka = if (aliases is []) "" else ", a.k.a.: " + saliases.ToString (", ")
  match (tb.LookupMember ("RegisterOptions"))
    | [m is MethodBuilder] =>
      m.Body = 
        <[ $(m.Body); 
           AddOption (TheOption (
                $(f.Name : string), 
                [ .. $aliases ],
                $(desc : string) + " [" + TypeName (ref $(f.Name : dyn)) + 
                        ", def: " + $(f.Name : dyn).ToString () + $(aka : string) + "]", 
                s => Parse (s, ref $(f.Name : dyn))
           )) 
         ]>
    | _ => assert (false)


macro @=== (a, b)
  <[ $a == $b : object ]>

macro @!== (a, b)
  <[ $a != $b : object ]>

macro use_cache (cache_ref, expr) \
  syntax ("use_cache", "(", cache_ref, ")", expr)
  match (cache_ref)
    | <[ $cache [ $idx ] ]> =>
      <[
          mutable res;
          unless ($cache.TryGetValue ($idx, out res)) {
            res = $expr;
            $cache[$idx] = res;
          }
          res
      ]>
    | _ => assert (false)