/**
 * A revised version of the pre-0.9.5 dynamic-rules-tools
 * Now using the new hash-tables, and implementing scoping
 * as a 'stack' of hashtables.
 *
 * @todo reuse ChangeSets when applying the fix point operator
 * @todo provide constructs to handle do-while-like structures
 *       issues: - a break inside the do-while
 *               - propagation in the first run could be wrong
 * @todo investigate if BreakCS and SplitPos need (rulename, label)
 *       or if rulename + scoping of DR_BREAK suffices
 * @todo when we have a fork-and-merge, after the two change sets
 *       are merged, one of them is lost and not discarded. This needs
 *       to be fixed (unless the garbage collector takes care of this)
 */
module lang/dynamic-rules

imports
  collection/hash-table/common
  strategy/traversal/simple
  collection/set/indexed
  system/io/file

signature
  constructors
    RuleScope  : IndexedSet * Hashtable -> RuleScope
    ChangeSet  : IndexedSet * IndexedSet * Hashtable -> RuleScope

    Label      : String -> Label
    SplitPos   : String * String -> SplitPos
    BreakCS    : String * String -> BreakCS
    ContinueCS : String * String -> ContinueCS
    IgnoreB    : String -> IgnoreB
    IgnoreC    : String -> IgnoreC

    Catch       : String * String -> Catch
    Finally     : String -> Finally
    TryBlock    : Int * String * [Catch] * Finally -> TryBlock
    Structure   : String -> Structure
    IgnoreT     : String -> IgnoreT
    ThrowCS     : String * String -> ThrowCS
    ExceptionCS : String * String -> ExceptionCS

/**
 * Currently active rule set
 */
strategies

  /**
   * Retrieve the primitive dynamic rules hashtable.
   */
  dr-rule-sets-hashtable =
    prim("SSL_dynamic_rules_hashtable")

  /**
   * @type  _ -> List(RuleScope)
   */
  dr-get-rule-set(|name) =
    prim("SSL_hashtable_get", <dr-rule-sets-hashtable>, name)
    <+ dr-new-rule-set
       ; dr-set-rule-set(|name)

  dr-set-rule-set(|name) =
    where(
      ?ruleset
      ; prim("SSL_hashtable_put", <dr-rule-sets-hashtable>, name, ruleset)
    )

  dr-switch-rule-set(|name) =
    where(dr-get-rule-set(|name) => rs)
    ; dr-set-rule-set(|name)
    ; !rs

  // Note: the storing the currently active rule set should
  // be done in a global variable at the C level (probably).
  // We should abstract from that as much as possible and
  // just consider the rule-set as a value that can be
  // changed. Manipulating the content should be the same
  // for any storage solution we use.

  // a question to consider: should operations be relative
  // to the current rule-set or should we make a set of
  // operations that work on a named rule-set and deal
  // with the pointer change at a higer-level?

  // Well, we can actually have two APIs, one working on
  // the implicit global rule-set, and the other working
  // on the explicit representation.

  // whose responsibility is it to initialize the outer scope?
  // In the definition above an initial hashtable is created
  // when no rule-set was available yet.

strategies // high-level API with implicit rule set

  // Note that the compiler can generate a specifically named
  // rule for each of the strategies in this API, e.g,
  // add-rule-name, lookup-rule-name, etc. Then the compiler
  // can specialize the applications.

  dr-scope(s | name) =
    dr-begin-scope(|name)
    ; (s < dr-end-scope(|name)
         + dr-end-scope(|name); fail)

  /**
   * @type  t -> t
   */
  dr-begin-scope(|name) =
    where(
      dr-get-rule-set(|name)
      ; dr-add-scope
      ; dr-set-rule-set(|name)
    )

  /**
   * @type  t -> t
   */
  dr-end-scope(|name) =
    where(
      dr-get-rule-set(|name)
      ; dr-leave-scope
      ; dr-set-rule-set(|name)
    )

  dr-scopes(s | names) =
    dr-begin-scopes(|names)
    ; (s < dr-end-scopes(|names)
         + dr-end-scopes(|names); fail)

  /**
   * @type  t -> t
   */
  dr-begin-scopes(|names) =
    where(
      !names
      ; map({?name
             ; dr-get-rule-set(|name)
             ; dr-add-scope
             ; dr-set-rule-set(|name)})
    )

  /**
   * @type  t -> t
   */
  dr-end-scopes(|names) =
    where(
      !names
      ; map({?name
             ; dr-get-rule-set(|name)
             ; dr-leave-scope
             ; dr-set-rule-set(|name)})
    )

  /**
   * @type  t -> t
   */
  dr-start-change-set(|name) =
    where(
      dr-get-rule-set(|name)
      ; dr-start-change-set
      ; dr-set-rule-set(|name)
    )

  /**
   * @type  t -> t
   */
  dr-commit-change-set(|name) =
    where(
      dr-get-rule-set(|name)
      ; dr-commit-change-set
      ; dr-set-rule-set(|name)
    )

  /**
   * @type  t -> t
   */
  dr-discard-change-set(|name) =
    where(
      dr-get-rule-set(|name)
      ; dr-discard-change-set
      ; dr-set-rule-set(|name)
    )

  /**
   * @type  t -> t
   */
  dr-label-scope(|name, label) =
    where(
      dr-get-rule-set(|name)
      ; dr-label-scope(|label)
      ; dr-set-rule-set(|name)
    )

   /**
    * Get all scope labels ordered from inner, most recent, to outer, oldest.
    */

  dr-get-scope-labels(|name) =
    dr-get-rule-set(|name)
    ; dr-get-scope-labels

   /**
    * Get the first scope label for which s succeeds starting with the
    * inner, most recent, scope.
    */

  dr-get-first-scope-label(s|name) =
    dr-get-rule-set(|name)
    ; dr-get-first-scope-label(s)

strategies

  /**
   * Apply s in a state where the current dynamic rules for name are ignored.
   *
   * @param strategy to apply (a -> b)
   * @param name of the dynamic rules (String)
   * @type a -> b
   */
  dr-ignore-state(s|name) =
    where(
      dr-new-rule-set
      ; dr-switch-rule-set(|name) => rs
    )
  ; s
  ; where(<dr-set-rule-set(|name)> rs)

  /**
   * Apply s in a state where the current dynamic rules for names are ignored.
   *
   * @param strategy to apply (a -> b)
   * @param names of the dynamic rules (List(String))
   * @type a -> b
   */
  dr-ignore-states(s|names) =
    where(
       <map(dr-new-rule-set)> names
       ; zip(dr-switch-rule-set | names) => rss
    )
    ; s
    ; where(<zip(dr-set-rule-set | names)> rss)

strategies

  dr-lookup-rule(|name, key) =
    dr-get-rule-set(|name)
    ; dr-lookup-rule(|key)

  dr-lookup-all-rules(|name, key) =
    dr-get-rule-set(|name)
    ; dr-lookup-all-rules(|key)

  dr-lookup-rule-pointer(|name, key) =
    dr-get-rule-set(|name)
    ; dr-lookup-rule-pointer(|key)

  dr-all-keys(|name) =
    dr-get-rule-set(|name)
    ; dr-all-keys(|[], <new-iset>)

  dr-set-rule(|name, key, value) =
    where(
      dr-get-rule-set(|name)
      ; dr-set-in-rule-set(|key, [value])
      ; dr-set-rule-set(|name)
    )

  dr-set-rule(|name, label, key, value) =
    where(
      dr-get-rule-set(|name)
      ; dr-set-in-rule-set(|label, key, [value])
      ; dr-set-rule-set(|name)
    )

  dr-set-rule-vis(|name, label, key, value) =
    where(
      dr-get-rule-set(|name)
      ; dr-set-in-rule-set-vis(|label, key, [value])
      ; dr-set-rule-set(|name)
    )

  dr-set-rules-vis(|name, label, key, values) =
    where(
      dr-get-rule-set(|name)
      ; dr-set-in-rule-set-vis(|label, key, values)
      ; dr-set-rule-set(|name)
    )

  dr-undefine-rule(|name, key) =
    where(
      dr-get-rule-set(|name)
      ; dr-set-in-rule-set(|key, [])
      ; dr-set-rule-set(|name)
    )

  dr-undefine-rule(|name, label, key) =
    where(
      dr-get-rule-set(|name)
      ; dr-set-in-rule-set(|label, key, [])
      ; dr-set-rule-set(|name)
    )

  dr-undefine-rule-vis(|name, label, key) =
    where(
      dr-get-rule-set(|name)
      ; dr-set-in-rule-set-vis(|label, key, [])
      ; dr-set-rule-set(|name)
    )

  dr-add-rule(|name, key, value) =
    where(
      dr-get-rule-set(|name)
      ; dr-add-to-rule-set(|key, value)
      ; dr-set-rule-set(|name)
    )

  dr-add-rule(|name, label, key, value) =
    where(
      dr-get-rule-set(|name)
      ; dr-add-to-rule-set(|label, key, value)
      ; dr-set-rule-set(|name)
    )

  dr-add-rule-vis(|name, label, key, value) =
    where(
      dr-get-rule-set(|name)
      ; dr-add-to-rule-set-vis(|label, key, value)
      ; dr-set-rule-set(|name)
    )

  /**
   * Intersect live rule-set with given rule set changing the live rule set.
   */

  dr-intersect-with(|name) =
    <dr-intersect-rule-sets>(<dr-get-rule-set(|name)>, <id>)
    ; dr-set-rule-set(|name)

  /**
   * Intersect live rule-set with given rule set changing both.
   */

  dr-intersect-symm(|name) =
    <dr-intersect-rule-sets-symm>(<dr-get-rule-set(|name)>, <id>)
    ; dr-set-rule-set(|name)

  /**
   * Merge live rule-set with given rule set using union changing the live rule set.
   */

  dr-union-with(|name) =
    <dr-union-rule-sets>(<dr-get-rule-set(|name)>, <id>)
    ; dr-set-rule-set(|name)

  /**
   * Merge live rule-set with give rule set using union changing both.
   */

  dr-union-symm(|name) =
//    <dr-union-rule-sets-symm>(<id>, <dr-get-rule-set(|name)>)
    <dr-union-rule-sets-symm>(<dr-get-rule-set(|name)>, <id>)
    ; dr-set-rule-set(|name)


  /**
   * Left choice with dynamic rule roll-back in case s1 fails.
   */

  dr-left-choice(s1,s2|rulenames) =
    where(<map(dr-start-change-set(|<id>))> rulenames)
    ; s1
    < where(<map(dr-commit-change-set(|<id>))> rulenames)
    + where(<map(dr-discard-change-set(|<id>))> rulenames)
      ; s2

/**
 * Low-level API working directly on rule-set.
 */

strategies // debugging

  dr-save-rule-set =
    alltd(hashtable-getlist)

strategies // scope

  // a rule-set is represented by a list of (label list, hash-table) pairs

  dr-new-scope =
    !RuleScope(<new-iset; iset-add(|())>, <new-hashtable>)

  dr-new-rule-set =
    ![<dr-new-scope>]

  dr-add-scope =
    ![<dr-new-scope> | <id>]

  dr-destroy-scope =
    RuleScope(iset-destroy, hashtable-destroy)

  dr-leave-scope :
    [scope | scopes] -> scopes
    where <dr-destroy-scope> scope

  dr-get-inner-scope :
    [scope | scopes] -> scope

  dr-label-scope(|label) =
    [ RuleScope(iset-add(|label), id)
      + ChangeSet(iset-add(|label), id, id)
    | id]
    // todo: distinction between rulescope and changeset necessary here or not??
//    [RuleScope(labels, tbl) | scopes] -> [RuleScope([label | labels], tbl) | scopes]

   dr-get-scope-labels =
     mapconcat(?RuleScope(<iset-elements>,_) + ?ChangeSet(<iset-elements>,_,_))

   /**
    * Get the first scope label for which s succeeds.
    */

   dr-get-first-scope-label(s) =
     fetch-elem(?RuleScope(<iset-elements; fetch-elem(s)>,_)
                + ?ChangeSet(<iset-elements; fetch-elem(s)>,_,_))

strategies // change sets

  dr-new-change-set =
    !ChangeSet(<new-iset>, <new-iset>, <new-hashtable>)

  dr-start-change-set =
    ![<dr-new-change-set> | <id>]

  dr-destroy-change-set =
    ChangeSet(iset-destroy, iset-destroy, dr-destroy-and-unmark)

  dr-destroy-and-unmark =
    ?Hashtable(csid)
    ; hashtable-destroy
    ; try(
        <DR_BREAK>IgnoreB(csid) => labelb
        ; rules(DR_BREAK.labelb :- IgnoreB(csid))
      )
    ; try(
        <DR_BREAK>IgnoreC(csid) => labelc
        ; rules(DR_BREAK.labelc :- IgnoreC(csid))
      )
    ; try(
        <DR_EXCEPTION>IgnoreT(csid)
        ; rules(DR_EXCEPTION :- IgnoreT(csid))
      )

  dr-clone-change-set =
    ?ChangeSet(labels1, rmset1, tbl1)
    ; dr-new-change-set => cs@ChangeSet(labels2, rmset2, tbl2)
    ; <iset-addlist(|<iset-elements>labels1)>labels2
    ; <iset-addlist(|<iset-elements>rmset1)>rmset2
    ; <hashtable-keys>tbl1
    ; map({key : ?key; <hashtable-put(|key, <hashtable-get(|key)>tbl1)>tbl2})
    ; !cs

  dr-commit-change-set =
    dr-commit-change-set(id)

  /**
   * The strategy destroy indicates whether the change
   * set should also be destroyed after the commmit.
   */
  dr-commit-change-set(destroy) :
    [cs@ChangeSet(labelset, rmset, tbl@Hashtable(csid)) | rs] -> rs''
    where <hashtable-keys> tbl
        ; foldr(<dr-commit-labels(|labelset)> rs
               , dr-apply-change(|tbl)) => rs'
        ; <iset-elements> rmset
        ; foldr(!rs', dr-apply-removal) => rs''
        ; try(
            destroy
            ; <DR_BREAK>IgnoreB(csid) => labelb
            ; (<fetch(ChangeSet(id, id, ?Hashtable(csidnextb)))>rs''
               ; dr-define-ignoreB(|csidnextb, labelb)
               <+ fatal-err(|"dr-break was called outside of a fix and merge operator or a dr-label call"))
          )
        ; try(
            destroy
            ; <DR_BREAK>IgnoreC(csid) => labelc
            ; (<fetch(ChangeSet(id, id, ?Hashtable(csidnextc)))>rs''
               ; dr-define-ignoreC(|csidnextc, labelc)
               <+ fatal-err(|"dr-continue was called outside of a fix and merge operator call"))
          )
        ; try(
            destroy
            ; <DR_EXCEPTION>IgnoreT(csid)
            ; (<fetch(ChangeSet(id, id, ?Hashtable(csidnextt)))>rs''
               ; dr-define-ignoreT(|csidnextt)
               <+ fatal-err(|"dr-throw was not called in the proper exception handling context"))
          )
        ; try(destroy; <dr-destroy-change-set> cs)

  dr-discard-change-set :
    [cs@ChangeSet(_, _, _) | rs] -> rs
    where <dr-destroy-change-set> cs

  dr-commit-labels(|labelset) =
    [ ChangeSet(iset-union(|labelset), id, id)
      + RuleScope(iset-union(|labelset), id)
    | id]

  /**
   * commit to ruleset is finding the first ChangeSet (any) *or* the first
   * RuleScope that has the appropriate scopeid (i.e. hashtable pointer)
   * and setting the key-value into it
   */

  dr-apply-change(|tbl) :
    (key1@(scpid, key), rs) -> <dr-commit-to-rule-set(|scpid, key, <hashtable-get(|key1)> tbl)> rs


  dr-commit-to-rule-set(|scpid, key, value) =
    dr-commit-to-change-set(|scpid, key, value)
    <+ dr-commit-to-rule-scope(|scpid, key, value)

  dr-commit-to-change-set(|scpid, key, value) =
    ?[ChangeSet(_, rmset, tbl) | rs]
    ; where(
        (<dr-lookup-rule-in-scope(|key, scpid)>rs => value
         < <hashtable-remove(|(scpid, key))>tbl
         + <hashtable-put(|(scpid, key), value)>tbl)
        ; <iset-remove(|(scpid, key))>rmset
      )

  dr-commit-to-rule-scope(|scpid, key, value) =
    ?[RuleScope(_, tbl@Hashtable(scpid)) | rs]
    ; where(<hashtable-put(|key, value)>tbl)
    <+ [RuleScope(id, id) | dr-commit-to-rule-set(|scpid, key, value) ]

/*
 * the old implementation (for reference)
 *

  dr-commit-to-rule-set(|scpid, key, value) =
    fetch(
      dr-commit-to-change-set(|scpid, key, value)
    + dr-commit-to-rule-scope(|scpid, key, value))

  dr-commit-to-change-set(|scpid, key, value) =
    ?ChangeSet(_, _, tbl)
    ; where(<hashtable-put(|(scpid, key), value)> tbl)

  dr-commit-to-rule-scope(|scpid, key, value) =
    ?RuleScope(_,tbl@Hashtable(scpid))
    ; where(<hashtable-put(|key, value)> tbl)
*/

  dr-apply-removal :
    (key1@(scpid, key), rs) -> <dr-remove-from-rule-set(|scpid, key)> rs

  dr-remove-from-rule-set(|scpid, key) =
    fetch(
      dr-remove-from-change-set(|scpid, key)
    + dr-remove-from-rule-scope(|scpid, key))

  dr-remove-from-change-set(|scpid, key) =
    ChangeSet(id, iset-add(|(scpid, key)), ?tbl)
  ; where(<hashtable-remove(|(scpid, key))> tbl)

  dr-remove-from-rule-scope(|scpid, key) =
    ?RuleScope(_,tbl@Hashtable(scpid))
  ; where(<hashtable-remove(|key)> tbl)

strategies // looking up

  /**
   * Fetch the most recent definition for key.
   */

  // The "removed" parameter is now a list, which allows duplicates
  // to be added. This is not wrong, but it is marginally inefficient.
  // We actually need set-like behavior. Indexed sets, however, are
  // not an option because of the check of whether or not "removed"
  // contains key' in function look2. Since look2 is called later on,
  // when a RuleScope is reached, "removed" will potentially contain
  // some extra elements which should not be considered. This is the
  // case because of the in-place update of indexed sets.

  dr-lookup-rule(|key) =
    dr-lookup-rule(fail | key, [])

  dr-lookup-rule(look | key, removed) =
    ?[RuleScope(_, tbl@Hashtable(hptr)) | rs]
    ; (<look>(hptr, key)
       <+ <not(fetch(?(hptr, key)))> removed
          ; <hashtable-get(|key)> tbl
       <+ <dr-lookup-rule(look | key, removed)> rs)

  dr-lookup-rule(look1 | key, removed) =
    ?[ChangeSet(_, rmset, tbl) | rs]
    ; let look2 = look1
                  <+ {key':
                      ?key'
                      ; <not(fetch(?key'))> removed
                      ; <hashtable-get(|key')> tbl
                     }
       in
         <iset-elements> rmset
         ; filter(?(_, key)) => keys
         ; <dr-lookup-rule(look2 | key, <conc>(keys, removed))> rs
      end

  /**
   * Version of dr-lookup-rule that looks for definition of a key
   * in a particular scope. The expected scope id (scpid) is the
   * pointer to the hashtable of a rule scope and is usually
   * identified by means of a label, i.e., a label indicates the
   * rule scope and the rule scope has a unique scope id.
   */

  dr-lookup-rule-in-scope(|key, scpid) =
    dr-lookup-rule-in-scope-rs(|key, scpid)
    <+ dr-lookup-rule-in-scope-cs(|key, scpid)

  dr-lookup-rule-in-scope-rs(|key, scpid) =
    ?[RuleScope(_, tbl@Hashtable(scpid)) | rs]      // if this is the right scope,
    < <hashtable-get(|key)>tbl                      // then check for key
    + (?[RuleScope(_, _) | rs]                      // else recurse
       ; <dr-lookup-rule-in-scope(|key, scpid)>rs)

  dr-lookup-rule-in-scope-cs(|key, scpid) =
    ?[ChangeSet(_, rmset, tbl) | rs]
    ; (<iset-contains(|(scpid, key))>rmset
       < fail                                // key is marked for removal, so
                                             // in effect it is not defined
       + (<hashtable-get(|(scpid, key))>tbl
          <+ <dr-lookup-rule-in-scope(|key, scpid)>rs))

  /**
   * Fetch the most recent definition for key and return a pointer
   * to the table that defines it.
   */

  dr-lookup-rule-pointer(|key) =
    dr-lookup-rule-pointer(fail | key, [])

  dr-lookup-rule-pointer(look | key, removed) =
    ?[RuleScope(_, tbl@Hashtable(hptr)) | rs]
    ; (<look>(hptr, key)
       <+ <not(fetch(?(hptr, key)))> removed
          ; <hashtable-get(|key)> tbl
          ; !(<id>, key, tbl)
       <+ <dr-lookup-rule-pointer(look | key, removed)> rs)

  dr-lookup-rule-pointer(look1 | key, removed) =
    ?[ChangeSet(_, rmset, tbl) | rs]
    ; let look2 = look1
                  <+ {key':
                      ?key'
                      ; <not(fetch(?key'))> removed
                      ; <hashtable-get(|key'); !(<id>, key', tbl)> tbl
                     }
       in
         <iset-elements> rmset
         ; filter(?(_, key)) => keys
         ; <dr-lookup-rule-pointer(look2 | key, <conc>(keys, removed))> rs
      end

  /**
   * Fetch all definitions for key.
   */

  dr-lookup-all-rules(|key) =
    dr-lookup-all-rules(fail | key, [])

  dr-lookup-all-rules(look | key, removed) =
    ?[RuleScope(_, tbl@Hashtable(hptr)) | rs]
    ; <conc>(<<look>(hptr, key)
              <+ <not(fetch(?(hptr, key)))> removed
                 ; <hashtable-get(|key)> tbl
              <+ ![]>
            ,<dr-lookup-all-rules(look | key, removed) <+ ![]> rs)

  dr-lookup-all-rules(look1 | key, removed) =
    ?[ChangeSet(_, rmset, tbl) | rs]
    ; let look2 = look1
                  <+ {key':
                      ?key'
                      ; <not(fetch(?key'))> removed
                      ; <hashtable-get(|key')> tbl
                     }
       in
         <iset-elements> rmset
         ; filter(?(_, key)) => keys
         ; <dr-lookup-all-rules(look2 | key, <conc>(keys, removed))> rs
      end

  /**
   * Fetch all keys defined in a rule set.
   */

  dr-all-keys(|removed, result) =
    ?[RuleScope(_, tbl@Hashtable(hptr)) | rs]
    ; <partition(?(hptr, <id>))>removed => (localr, removed')
    ; <hashtable-keys>tbl
    ; filter({key: ?key; <not(fetch-elem(?key))>localr; !key}) => keys
    ; <iset-addlist(|keys)>result
    ; <dr-all-keys(|removed', result)>rs

  dr-all-keys(|removed, result) =
    ?[ChangeSet(_, rmset, tbl) | rs]
    ; <iset-elements>rmset
    ; <conc>(<id>, removed) => removed'
    ; <hashtable-keys>tbl
    ; filter({k, key: ?k@(_, key); <not(fetch-elem(?k))>removed'; !key}) => keys
    ; <iset-addlist(|keys)>result
    ; <dr-all-keys(|removed', result)>rs

  dr-all-keys(|removed, result) =
    ?[]; <iset-elements>result

strategies // setting a rule

  // A rule is always stored as a mapping from key to a list of values.
  // Setting a rule entails removing previous rules.

  /**
   * set a rule in the inner scope
   *
   * The inner scope has label () since all scopes are labeled
   * this way.
   */

  dr-set-in-rule-set(|key, value) =
    dr-set-in-rule-set(|(), key, value)

  /**
   * set a rule in the scope with specified label
   */

  dr-set-in-rule-set(|label, key, value) =
    dr-set-in-rule-set(dr-set-fail | label, key, value)

  dr-set-fail(|scpid, tbl, key, value) =
    fail

  dr-set-in-rule-set(set : ATerm * Hashtable * ATerm * ATerm * ATerm -> ATerm
           | label, key, value) =
    ?[RuleScope(labelset, tbl@Hashtable(hptr)) | rs]
    ; where(
        <iset-contains(|label)> labelset
        < (set(|hptr, tbl, key, value)
           <+ where(<hashtable-put(|key, value)> tbl))
        + <dr-set-in-rule-set(set | label, key, value)> rs
      )

  dr-set-in-rule-set(set1 : ATerm * Hashtable * ATerm * ATerm * ATerm -> A