# $Id: s.Serializer.xotcl 1.4 01/03/23 21:55:33+01:00 neumann@somewhere.wu-wien.ac.at $
package require XOTcl 0.84
package provide xotcl::scriptCreation::serializer 0.1

@ @File {
    description {
      This package provides the class Serializer, which can be used to
      generate a snapshot of the current state of the workspace
      in the form of an XOTcl source code
    }
    authors {
        Gustaf Neumann, Gustaf.Neumann@wu-wien.ac.at
        Uwe Zdun, uwe.zdun@uni-essen.de
    }
    date { $Date: 01/03/23 21:55:33+01:00 $ }
}
  
@ Serializer instproc serializeWs {?fn? "optional filename"} {
  Description {
    Serialize all objects and classes that are currently 
    defined. If fn is not specified the function returns the source 
    code to recreate the workspace. If fn is specified the source 
    code is written into the specified file.
  }
  return "script or empty string"
}

@ Serializer instproc serialize {entity "Object or Class"} {
  Description {
    Serialize the specified object or class.
  }
  return {Object or Class with all currently defined methods, 
    variables, invariants, filters and mixins}
}

Class Serializer
Serializer instproc ignore args {
  foreach i $args { [self] set skip($i) 1 }
}
Serializer instproc init {} {
  [self] ignore [self] [self class] \
      ::Class ::Object ::Object::CopyHandler ::Class::Parameter \
      ::@ ::xotcl ::xotcl::rcs
}
Serializer instproc method-serialize {o m prefix} {
  set arglist ""
  foreach v [$o info ${prefix}args $m] {
    if {[$o info ${prefix}default $m $v x]} {
      lappend arglist [list $v $x] } {
      lappend arglist $v }
  }
  lappend r $o ${prefix}proc $m $arglist [$o info ${prefix}body $m]
  foreach p {pre post} {
    if {[$o info ${prefix}$p $m]!=""} {lappend r [$o info ${prefix}$p $m]}
  }
  return $r
}
Serializer instproc Object-serialize o {
  append cmd [list [$o info class] create $o \
		  -mixin ::xotcl::NoInit -init -mixin {}] \n
  foreach i [$o info procs] {
    append cmd [[self] method-serialize $o $i ""] \n
  }
  foreach v [$o info vars] {
    if {[$o array exists $v]} {
      append cmd [list $o array set $v [$o array get $v]] \n
    } else {
      append cmd [list $o set $v [$o set $v]] \n
    }
  }
  foreach x {mixin invar} {
    if {[$o info $x] != ""} {append cmd [list $o $x [$o info $x]] \n}
  }
  return $cmd
}
Serializer instproc Class-serialize o {
  set cmd [[self] Object-serialize $o]
  foreach i [$o info instprocs] {
    append cmd [[self] method-serialize $o $i inst] \n
  }
  foreach x {superclass instmixin filter instinvar} {
    if {[$o info $x]!=""} {append cmd [list $o $x [$o info $x]] \n}
  }
  return $cmd\n
}

Serializer instproc args {o prefix m} {
  foreach v [$o info ${prefix}args $m] {
    if {[$o info ${prefix}default $m $v x]} {
      lappend arglist [list $v $x] } {
      lappend arglist $v }
  }
  return $arglist
}
Serializer instproc category c {
  if {[$c istype ::Class]} {return Class} {return Object}
}
Serializer instproc allInstances C {
  set set [$C info instances]
  foreach sc [$C info subclass] {
    eval lappend set [[self] allInstances $sc]
  }
  return $set
}
Serializer instproc topoSort {set} {
  if {[[self] array exists s]} {[self] array unset s}
  foreach c $set {
    if {[[self] exists skip($c)]} continue
    [self] set s($c) 1
  }
  set stratum 0
  while {1} {
    set set [[self] array names s]
    if {[llength $set] == 0} break
    incr stratum
    #puts "$stratum set=$set"
    [self] set level($stratum) {}
    foreach c $set {
      if {[[self] [[self] category $c]-needsNothing $c]} {
	[self] lappend level($stratum) $c
      }
    }
    foreach i [[self] set level($stratum)] {[self] unset s($i)}
  }
}
Serializer instproc Class-needsNothing x {
  if {![[self] Object-needsNothing $x]}         {return 0}
  if {[[self] needsOneOf [$x info superclass]]} {return 0}
  if {[[self] needsOneOf [$x info instmixin ]]} {return 0}
  return 1
}
Serializer instproc Object-needsNothing x {
  set p [$x info parent]
  if {$p != "::" && [[self] needsOneOf $p]} {return 0}
  if {[[self] needsOneOf [$x info class]]}  {return 0}
  if {[[self] needsOneOf [$x info mixin ]]} {return 0}
  return 1
}
Serializer instproc needsOneOf list {
  foreach e $list {if {[[self] exists s($e)]} {return 1}}
  return 0
}
Serializer instproc serialize {objectOrClass} {
  [self] [[self] category $objectOrClass]-serialize $objectOrClass
}
Serializer instproc serializeWs {{fn ""}} {
  [self] topoSort [[self] allInstances ::Object]
  #foreach i [lsort [[self] array names level]] {
  #  puts "$i: [[self] set level($i)]"
  #}
  set result ""
  foreach l [lsort [[self] array names level]] {
    foreach i [[self] set level($l)] {
      append result [[self] serialize $i]
    }
  }
  if {$fn == ""} {
    return $result
  } else {
    set f [open $fn w]
    puts $f $result
    close $f
  }
}
