src/lib/path.slate

   1 define: #Path &slots: {#names -> ExtensibleArray new}.
   2 "A Path represents a sequence of slot-name traversals which can be used to
   3 reach a destination.  Nil represents impossible path."
   4
   5 s@(Sequence traits) as: path@(Path traits)
   6 [path clone `setting: #{#names} to: {s as: path names}].
   7
   8 Path traits compareAndHashUsingSlots: #{#names}.
   9
  10 path@(Path traits) hash
  11 [path names hash bitXor: path traits identityHash].
  12
  13 path@(Path traits) from: root into: names foundBlock: foundBlock
  14                    &filterBlock: filterBlock
  15 "Core of the path-searching functionality, contains the algorithm for
  16 breadth-first search of path between objects through slots.
  17
  18 'root' is the object where the search begins.
  19 'names' is WriteStream into which are symbols specifying found path added.
  20 'foundBlock' - predicate block for termination on {source. name. target}.
  21 'filterBlock' - predicate block to pre-filter the queue on {src. name. tgt}.
  22
  23 Answers the target object where the found path leads to, or Nil if requested
  24 path does not exist."
  25 [| pathLookupQueue seen |
  26   (foundBlock apply*, root, Nil, root) ifTrue: [^ root].
  27   seen := IdentitySet newWith: root.
  28   filterBlock `defaultsTo: [| :src :name :tgt | True].
  29   pathLookupQueue :=
  30     (ExtensibleArray newWith: ExtensibleArray new -> root).
  31   [pathLookupQueue isEmpty] whileFalse:
  32     [| pathLookup lookupObject |
  33       pathLookup := pathLookupQueue removeFirst.
  34       lookupObject := pathLookup value.
  35       "Check named slots."
  36       lookupObject slotNames do:
  37         [| :slotName slotValue |
  38           slotValue := lookupObject atSlotNamed: slotName.
  39           [(seen accepts: slotValue) /\ [(seen includes: slotValue) not]
  40             ifTrue:
  41               [| newPath |
  42                 seen include: slotValue.
  43                 newPath := pathLookup key copy.
  44                 newPath addLast: slotName.
  45                 (foundBlock apply*, lookupObject, slotName, slotValue)
  46                   ifTrue: [names ; newPath. ^ slotValue].
  47                 (filterBlock apply*, lookupObject, slotName, slotValue)
  48                   ifTrue: [pathLookupQueue addLast: newPath -> slotValue]]
  49           ] breakOn: MethodNotFound].
  50       "Check indexed slots."
  51       lookupObject hasIndexedSlots ifTrue:
  52         [lookupObject keysDo:
  53           [| :index slotValue |
  54            slotValue := lookupObject at: index.
  55            (seen accepts: slotValue) /\ [(seen includes: slotValue) not]
  56              ifTrue:
  57                [| newPath |
  58                 seen include: slotValue.
  59                 newPath := pathLookup key copy.
  60                 newPath addLast: index.
  61                 (foundBlock apply*, lookupObject, index, slotValue)
  62                   ifTrue: [names ; newPath. ^ slotValue].
  63                 (filterBlock apply*, lookupObject, index, slotValue)
  64                   ifTrue: [pathLookupQueue addLast: newPath -> slotValue]]]]].
  65   Nil
  66 ].
  67
  68 path@(Path traits) from: root to: target
  69 "Answer a Path between the given objects, using a raw breadth-first search
  70 through all slot paths, avoiding duplicate visits.  Answers Nil when no path
  71 can be found."
  72 [| names |
  73   names := path names new writer.
  74   (path from: root into: names foundBlock: [| :_ :_ :value | value == target])
  75     ifNotNil: [names contents as: RootedPath]
  76 ].
  77
  78 path@(Path traits) to: obj
  79 "Answer a path from the current namespace to the given object."
  80 [path from: here to: obj].
  81
  82 path1@(Path traits) ; path2@(Path traits)
  83 [
  84   path1 names ; path2 names as: path1
  85 ].
  86
  87 path@(Path traits) childNamed: name
  88 [
  89   (path expanded names copyWith: name) as: path
  90 ].
  91
  92 path@(Path traits) parent
  93 [
  94   path names allButLast as: path
  95 ].
  96
  97 path1@(Path traits) isPrefixOf: path2@(Path traits)
  98 [
  99   path1 names isPrefixOf: path2 names
 100 ].
 101
 102 path@(Path traits) targetFrom: root
 103 "Answer the target object that the Path points to, starting from the given
 104 object and following each name/index."
 105 [
 106   [path names inject: root into:
 107     [| :obj :eachName |
 108      "Is the name for a named or indexed slot?"
 109      (eachName isSameAs: Symbol)
 110        ifTrue: [obj atSlotNamed: eachName]
 111        ifFalse: [obj at: eachName]]]
 112    on: SlotNotFound do: [| :c | ^ Nil]
 113 ].
 114
 115 path@(Path traits) target
 116 "Assume that the the current namespace is the root of the path."
 117 [path targetFrom: here].
 118
 119 path@(Path traits) printOn: s &root: root
 120 [
 121   s ; '("' ; path printName ; '" '.
 122   path names
 123     do: [| :slotName | s ; slotName printString]
 124     separatedBy: [s nextPut: $\s].
 125   root ifNotNil: [s ; ' root: '. root printOn: s].
 126   s ; ')'
 127 ].
 128
 129 define: #RootedPath &parents: {Path} &slots: {#root -> lobby}.
 130 "A Path that is based on a particular root object."
 131
 132 rooted@(RootedPath traits) as: path@(Path traits)
 133 "Answer a path with the root object forgotten."
 134 [rooted names as: path].
 135
 136 p1@(RootedPath traits) = p2@(RootedPath traits)
 137 [(p1 root = p2 root) /\ [p1 names = p2 names]].
 138
 139 path@(RootedPath traits) unrooted
 140 [path as: Path].
 141
 142 path@(RootedPath traits) from: root to: target
 143 [
 144   resend ifNotNilDo: [| :newP | newP names as: path &root: root]
 145 ].
 146
 147 s@(Sequence traits) as: path@(RootedPath traits) &root: root
 148 [
 149   path clone `setting: #{#names. #root}
 150        to: {(s collect: [| :each | (each is: Integer)
 151                                    ifTrue: [each] ifFalse: [each intern]])
 152                 as: path names.
 153             root ifNil: [here]}
 154 ].
 155
 156 m@(nodes UnaryMessage traits) as: path@(Path traits) &root: root
 157 [| names node |
 158   names := ExtensibleArray new.
 159   node := m.
 160   [names addFirst: node selector.
 161    node := node argument.
 162    node isSameAs: m] whileTrue.
 163   names as: path &root: root
 164 ].
 165
 166 m@(nodes ImplicitArgument traits) as: path@(Path traits) &root: root
 167 [path from: (root ifNil: [here]) to: here].
 168
 169 m@(nodes Parenthesis traits) as: path@(Path traits) &root: root
 170 [m statements size = 1 ifTrue: [m statements first as: path &root: root]].
 171
 172 path@(Path traits) as: _@(nodes Node traits)
 173 [
 174   path expanded names inject: nodes ImplicitArgument into:
 175     [| :result :each |
 176      (each is: Integer)
 177        ifTrue: [nodes KeywordMessage sending: #at: to:
 178          {result. nodes Literal for: each}]
 179        ifFalse: [nodes UnaryMessage sending: each intern to: {result}]]
 180 ].
 181
 182 path@(RootedPath traits) unrooted [path as: Path].
 183
 184 path@(RootedPath traits) target
 185 [
 186   path expanded targetFrom: path root
 187 ].
 188
 189 path@(RootedPath traits) isDefined
 190 "Answer whether following the path from the root yields something."
 191 [path target isNotNil].
 192
 193 path@(RootedPath traits) isOneSlotFromDefinition
 194 "Answer whether the path is not defined but the immediate parent is."
 195 [path isDefined not /\ [path parent isDefined]].
 196
 197 path@(RootedPath traits) reduced
 198 "Answer a path consisting of the minimum set of accessor method lookups to
 199 reach the same object."
 200 [| names this |
 201   names := path names new writer.
 202   this := path root.
 203   path names do:
 204     [| :each |
 205      (each is: Integer)
 206        ifTrue: [this hasIndexedSlots /\ [this acceptsKey: each]
 207                   ifTrue: [names nextPut: each]
 208                   ifFalse: [each keyNotFoundOn: this]]
 209        ifFalse:
 210          [(this hasSlotNamed: each)
 211             ifTrue: [(this hasDelegateNamed: each)
 212                        ifFalse: [names nextPut: each].
 213                      this := this atSlotNamed: each]
 214             ifFalse: [this slotNotFoundNamed: each]]].
 215   names contents isEmpty /\ [path names isEmpty not]
 216     ifTrue: [names nextPut: path names last].
 217   names contents as: path
 218 ].
 219
 220 path@(RootedPath traits) expanded
 221 "Answer a path consisting of the full set (through all delegations) of
 222 accessor method lookups to reach the same object. This performs a search and
 223 returns the shortest delegation path compatible with the original path's slot
 224 names. If the path doesn't work, then those lookups are added unconditionally
 225 (we can't be smart about error-handling here - let the client deal with the
 226 data unfiltered)."
 227 [| names this |
 228   names := path names new writer.
 229   this := path root.
 230   path names do:
 231     [| :each target |
 232      (path from: this into: names
 233            foundBlock: [| :_ :name :_ | name == each]
 234            &filterBlock: [| :obj :name :_ | obj hasDelegateNamed: name])
 235        ifNil: [names nextPut: each]
 236        ifNotNilDo: [| :target | this := target]].
 237   names contents as: path &root: path root
 238 ].
 239
 240 path@(RootedPath traits) printOn: s &root: root
 241 [
 242   root `defaultsTo: path root.
 243   resend
 244 ].
 245
 246 x@(Root traits) knows: obj
 247 [(Path from: x to: obj) isNotNil].
 248
 249 x@(Root traits) isWellKnown
 250 [lobby knows: x].
 251
 252 x@(Root traits) whereIs: obj
 253 "Answers a path from the first argument to the second."
 254 [RootedPath from: x to: obj].
 255
 256 define: #PathFinder &parents: {ReadStream} &slots:
 257   {#source -> (TraversalStream newOn: lobby &childrenVia: #slotValues `er).
 258    #filterBlock -> [| :src :name :tgt | True]. "predicate for avoidance on {source. name. target}."
 259    #foundBlock -> [| :src :name :tgt | x == Nil] "predicate for selection on {source. name. target}."}.
 260
 261 pf@(PathFinder traits) on: obj
 262 [pf source := pf source newOn: obj].
 263
 264 pf@(PathFinder traits) newFrom: root selecting: foundBlock &filterBlock: filterBlock
 265 [| newPF |
 266   newPF := pf newOn: root.
 267   foundBlock ifNotNil: [newPF foundBlock := foundBlock].
 268   filterBlock ifNotNil: [newPF filterBlock := filterBlock].
 269   newPF
 270 ].
 271
 272 pf@(PathFinder traits) reset
 273 [pf source reset. ].
 274
 275 pf@(PathFinder traits) next
 276 [
 277 ].