Revert "Revert "Made use of ::= in core libraries and defined a RebindError condition...

[cslatevm.git] / src / lib / module.slate

globals define: #modules &builder: [ExtensibleArray new].

_@lobby currentModule [Module current].
_@lobby currentModule: m [Module current: m].
"TODO: form and implement a generic (non-global) idea of the current module."

ns@(Namespace traits) enterModule: name
[
  modules include: name.
  currentModule: name
].

ns@(Namespace traits) provides: objects
[
  currentModule exports addAll: objects.
  features addAll: objects
].

ns@(Namespace traits) requires: objects
[
  currentModule imports addAll: objects.
  objects do:
    [| :requirement |
     (lobby features includes: requirement)
       ifFalse: [warn: 'Missing feature required for loading this: ' ; requirement printString]].
].

prototypes define: #Module
"Modules are a collection of objects and methods, which together provide
certain features, and require other modules' features to function."
  &slots: {
#requirements -> Set new.
"The set of modules that this requires before it can be loaded."
#imports -> Set new.
"Imports are objects and features referenced by the module's code."
#exports -> Set new.
"Exports are objects and features provided by the module's code."
#objects -> Set new.
"These are the non-method objects that the module defines and installs."
#methods -> Set new.
"These are the closures that the module defines and installs, whether named or
dispatched or anonymous."
#name -> ''}.

m@(Module traits) initialize
"Reset all of the module's attributes."
[
  m requirements := m requirements new.
  m imports := m imports new.
  m exports := m exports new.
  m objects := m objects new.
  m methods := m methods new.
  m
].

m@(Module traits) new &name: name
[
  m clone initialize `>> [name := name `defaultsTo: ''. ]
].

(Module traits hasSlotNamed: #current)
  ifFalse: [Module traits addSlot: #current valued: Module new].

m@(Module traits) newForFileNamed: filename
[
  FileModule newLocated: filename
].

m@(Module traits) copy
[m clone `setting: #{#requirements. #imports. #exports. #objects. #methods}
   to: {m requirements copy.
        m imports copy.
        m exports copy.
        m objects copy.
        m methods copy}
].

m@(Module traits) newBasedOn: moduleSet
[m clone initialize `>>
   [requirements := moduleSet select: #(is: Module) `er. ]].

m@(Module traits) provide: obj
[
  "TODO: include some check here to avoid arbitrary provision."
  m exports include: obj
].

m@(Module traits) provides: obj
[
  m exports includes: obj
].

m@(Module traits) import: obj from: prereq
[
  (prereq provides: obj)
    ifTrue: [m requirements include: prereq. m imports include: obj].
  m
].

m@(Module traits) allSelectorsSent
[
  [| :result | m methods do: [| :each | result ; each allSelectorsSent]]
    writingAs: IdentitySet
].

m@(Module traits) allSelectorsSentNotDefined
[
  [| :result | m methods do:
    [| :each |
     result ; (each allSelectorsSent reject:
                 [| :sel | m methods anySatisfy:
                             [| :method | method selector = sel]])]]
    writingAs: IdentitySet
].

m@(Module traits) importAll: c from: prereq
[
  c do: [| :each | (prereq provides: each)
    ifFalse: [^ (prereq error:
                   prereq name ; ' does not provide ' ; (each as: String))]].
  m requirements include: prereq.
  c do: [| :each | m imports include: each].
  m
].

m@(Module traits) defines: obj
[
  m defines: ((RootedPath to: obj) ifNil: [RootedPath to: obj traits])
].

m@(Module traits) defines: path@(Path traits)
[overrideThis].

m@(Module traits) load
"Loads the Module's contents, if external."
[overrideThis].

m@(Module traits) build
"Compiles the Module's contents, if external."
[overrideThis].

m@(Module traits) locator
[overrideThis].

prototypes define: #Load &parents: {Cloneable} &slots: {
  #source.
  #parser -> Syntax Parser.
  #targetNamespace -> lobby.
  #verbose -> False.
  #showMessage -> True.
}.
Load traits addSlot: #Level valued: 0.
"How many levels of recursion has load: been invoked on."
"TODO: This should be a dynamic, not a global."
Load traits define: #DefaultSourceDir &builder: [Directory current].
"Records the concrete directory where the sources are available and where
the bootstrap occurred."
Load traits define: #defaultPaths &builder: [{Load DefaultSourceDir} as: ExtensibleArray].

l@(Load traits) of: file@(File traits)
[| oldLevel |
  l resolvePathOf: file.
  oldLevel := l Level.
  l Level := l Level + 1.
  [file sessionDo:
     [| :input | l process: input reader] &mode: file Read]
    ensure: [l Level := oldLevel]
].

l@(Load traits) resolvePathOf: file@(File traits)
[
  (file locator isSameAs: file RelativeLocator)
    ifTrue:
      [[file exists] whileFalse:
        [(l defaultPaths before: file locator basePath)
          ifNil: [error: 'Could not find the file relative to any of the default directories.'. ^ Nil]
          ifNotNilDo: [| :newL | file locator basePath: newL]]]
].

l@(Load traits) retry
[
  l source reset.
  l source close. l source reopen.
  l process: l source.
].

l@(Load traits) process: source
[| retry skip ns |
  ns := Namespace new. 
  retry := ns define: #Retry &parents: {Restart}.
  _@retry describeOn: out
  [out ; 'Retry loading ' ; l source resource locator printString ;'\n'].
  skip := ns define: #Skip &parents: {Restart}.
  _@skip describeOn: out
  [out ; 'Skip loading ' ; l source resource locator printString ; '\n' ].
  l source := source.
  [l run] handlingCases: {retry -> [| :_ | ^ (l retry)].
                          skip -> [| :_ | ^ Nil]}.
].

l@(Load traits) printMessage
[
  l Level timesRepeat: [DebugConsole writer nextPut: $\s].
  inform: 'Loading ' ; l source resource locator printString &target: DebugConsole.
].

l@(Load traits) skipShebang
"Ignore an initial she-bang line."
[
  (l source peek: 2) = '#!' ifTrue: [l source upTo: $\n].
].

l@(Load traits) run
"Evaluate the input from the open source ReadStream."
[
  l showMessage ifTrue: [l printMessage].
  l skipShebang.
  "Ensure a fresh Parser."
  (l parser := l parser newOn: l source) do:
    [| :each |
     l verbose ifTrue:
       [l Level timesRepeat: [DebugConsole writer nextPut: $\s].
        inform: 'Parsed to line ' ; l parser lexer lineNumber printString &target: DebugConsole].
     [each evaluateIn: l targetNamespace]
       on: RebindError do: [| :c | c return]].
].

_@(Root traits) copyright
"Describes the copyright for given objects/source. Override this on a per-type
or per-module basis."
[
  (Load DefaultSourceDir / 'LICENSE') sessionDo: [| :in | in >> Console. ].
].

x@(Root traits) license
[x copyright].

"Override the more primitive load: commands with high level Module hooks:"

ns@(Namespace traits) load: fileName@(String traits) &imports: imports
[
  ns load: (fileName as: File Locator) &imports: imports
].

ns@(Namespace traits) load: locator@(File Locator traits) &in: namespace &verbose: verbose &showLoadMessage: showLoadMessage &imports: imports
"A command to open a file with the name, load, and compile/evaluate the
contents within the argument namespace or an optional override."
[| src |
  locator fileType = 'image' ifTrue:
    [error: 'Image filename specified where Slate source expected. Make sure you run slate with the -i flag to specify an image.'].
  src := File newNamed: locator &mode: File Read.
  src exists ifFalse: [locator fileType `defaultsTo: 'slate'].
  src exists
    ifTrue: [ns load: src &in: namespace &verbose: verbose &showLoadMessage: showLoadMessage &imports: imports]
    ifFalse: [warn: 'You tried to call load: on something that didn\'t describe a file. Returning the input: ' ; locator printString. locator]
].

ns@(Namespace traits) load: file@(File traits) &in: namespace
  &verbose: verbose &showLoadMessage: showMessage &imports: imports
"A command to open the file, load, and compile/evaluate the
contents within the argument namespace or an optional override."
[| oldLevel loader |
  namespace `defaultsTo: ns.
  (imports `defaultsTo: #{}) do: [| :import | namespace import: import value from: import key].
  loader := Load clone `>>
    [targetNamespace := namespace. verbose ?= verbose. showMessage ?= showMessage. ].
  loader resolvePathOf: file.
  oldLevel := loader Level.
  loader Level := loader Level + 1.
  [file ASCIIReader sessionDo: #(loader process: _) `er &mode: file Read]
    ensure: [loader Level := oldLevel].
].

prototypes define: #FileModule &parents: {Module} &slots: {#source -> File}.
"FileModules are Modules which are drastically simplified for the purposes of
bootstrapping. Requirements and provisions are symbols, and other features are
ignored."

m@(FileModule traits) newLocated: filename
[m new `>> [source := m source newNamed: filename &mode: File Read. ]].

f@(File traits) as: m@(Module traits)
[FileModule new `>> [source := f. ]].

m@(FileModule traits) locator
[m source locator].

m@(FileModule traits) load &in: namespace
[
  Load of: m source
].

m@(FileModule traits) build
[
  m load
].

m@(FileModule traits) readDefinitions
"Reads in a file, building the module's collections while evaluating the
contents."
"TODO: implement it!"
[
  m source
    sessionDo: [| :in | ].
  m
].

Module traits define: #DefinitionSelectors
              &builder: [#{#addPrototype:. #addPrototype:derivedFrom:.
                         #define:. #define:using:. #define:on:as:.
                         #ensureNamespace:}]
"Selectors for the standard accessor-producing definitions.".

m@(FileModule traits) parseSessionDo: block
[
  m source sessionDo:
    [| :input | block applyWith: (Syntax Parser newOn: input reader)]
].

m@(FileModule traits) definedPaths &in: namespace
"Answers a Set of Path objects that would be defined if the source were
evaluated."
[
  namespace `defaultsTo: here.
  [| :result |
   m parseSessionDo:
     [| :p |
      p do: [| :tree | tree walk:
        [| :node accessor partPath |
         "Handle the slot-based definitions which produce an accessor."
         (node is: Syntax Message)
           /\ [m DefinitionSelectors includes: node selector]
           /\ [node arguments second is: Syntax Literal]
           ifTrue:
             [accessor: node arguments second value.
              partPath: node arguments first]
           "Handle unary top-level method definitions."
           ifFalse:
             [(node is: Syntax MethodDefinition)
                /\ [node selector isUnarySelector]
                /\ [node parentScope isNil]
                ifTrue:
                  [accessor := node selector.
                   partPath := node roles first]].
         "Given an accessor, check the path for validity, then add it."
         accessor ifNotNil:
           [(partPath as: RootedPath &root: namespace) ifNotNilDo:
             [| :path | result nextPut: (path childNamed: accessor)]]
         ]]]] writingAs: Set
].

m@(FileModule traits) defines: path@(Path traits)
[m definedPaths includes: path].

globals ensureNamespace: #AutoLoader
"Manages 'autoloading' stubs - these are mock accessors for unloaded features
which load those features transparently and return them once done."
  &slots: {#defs -> Dictionary new.
           #storage -> (File newNamed: 'AutoLoad').
           #standardFiles -> (
  "Extra generic libraries."
  ({'extlib'. 'time'. 'dimensioned'. 'predicate'. 'group'. 'heap'. 'skiplist'.
    'tree'. 'tokenizer'. 'sortedSet'. 'relation'.
    'singleSet'. 'matrix'. 'wordarray'.
    'terminal'. 'version'. 'test'. 'random'. 'xml'.
    'suspension'. 'process'.
    'graph'. 'digraph'}
    collect: [| :name | 'src/lib/' ; name ; '.slate']) ;
  "Networking libraries, platform libraries."
  {'src/net/sockets.slate'. 'src/net/http.slate'} ;
  "Bootstrapper libraries."
  ({'bootstrap'. 'build'}
    collect: [| :name | 'src/mobius/' ; name ; '.slate']) as: Set)}.

l@AutoLoader readFromSourceIn: file
"Parses the source in the specified file and creates entries for each path
directly defined."
[| mod paths |
  mod := FileModule newLocated: file.
  (paths := mod definedPaths) do:
    [| :path |
     path isOneSlotFromDefinition /\ [(paths includes: path parent) not]
       ifTrue: [l defs at: path := mod]].
].

l@AutoLoader performScan &files: fileList
"Scans the source in the given collection of filenames or the default, adding
to the in-memory database."
[
  fileList `defaultsTo: l standardFiles.
  fileList do: [| :file |
                inform: 'Scanning \'' ; file ; '\''.
                l readFromSourceIn: file]
].

l@AutoLoader install: m@(Module traits) when: selector isCalledOn: namespace
"The basic unit of creating an auto-loading method. This checks for a pre-
existing method on the exact same object to avoid duplicate work, and informs
the user of the creation. The method itself tells the module to load itself,
which will presumably clobber that method called, so that the final action
of re-calling it will return the intended object."
[
  (selector isFoundOn: {namespace}) ifTrue: [^ Nil].
  inform: 'Installing auto-loader for: ' ; selector printString
   ; ' in: ' ; ((RootedPath from: here to: namespace) as: Syntax Node) printString.
  [| :ns |
   selector removeMethodFrom: {namespace}. "Remove this method before replacement."
   m load. "Have the module object load itself, presumably replacing this."
   l installReadyItems. "Have AutoLoader rescan for further hooks."
   "Re-call the method, presuming that the module installed a replacement."
   [selector sendTo: {ns}] on: MethodNotFound do:
     [| :c | error: 'The module failed to define this accessor.']]
    asMethod: selector on: {namespace}
].

l@AutoLoader installReadyItems
"Iterate through the in-memory definitions, installing methods for those
that are one slot definition away from completion."
[
  l defs keysAndValuesDo:
    [| :path :mod |
     path isOneSlotFromDefinition
       ifTrue:
         [l install: mod when: path names last isCalledOn: path parent target]]
].

l@AutoLoader readStorage &from: file &in: namespace
"Reads a quirky file format we've defined from path-spec -> locator-spec per
line in the text file or default storage."
[
  file `defaultsTo: l storage.
  namespace `defaultsTo: here.
  file exists
    ifFalse: [warn: 'The database file for auto-loaders is not present.'.
              ^ Nil].
  file sessionDo:
    [| :f r |
     r := f reader lines.
     [r isAtEnd] whileFalse:
       [r next ifNotNilDo:
         [| :line |
          (line indexOfSubSeq: ' ->') ifNotNilDo:
            [| :splitIndex path filename |
             path := (line first: splitIndex + 1) split
               as: RootedPath &root: namespace.
             filename := String readFrom: (line copyFrom: splitIndex + 4).
             AutoLoader defs at: path := FileModule newLocated: filename]]]].
  l installReadyItems
].

l@AutoLoader writeToStorage
"Writes definitions to the default storage."
[
  l storage sessionDo:
    [| :f out |
     out := f writer.
     l defs keysAndValuesDo:
       [| :path :mod |
        out ; ((path as: Syntax Node) printString
          ; ' -> ' ; (mod locator as: String) printString as: ByteArray) ; '\n']]
    &mode: l storage CreateWrite.
].

lobby ensureNamespace: #systems.

prototypes define: #System &slots: {#modules -> Set new}.

s@(System traits) newForAll: modules
"Creates a new System object for the given Module objects."
[(s clone `setting: #{#modules} to: {modules as: s modules}) `>>
   [| :newS | modules do: [| :each | newS fillRequirementsFor: each]. ]
].

s@(System traits) fillRequirementsFor: module
"Fills the requirements slot of the module, based on the knowledge that the
System has by holding several other Modules, and return the requirements."
[| features covered |
  features := module imports.
  covered := Set newSizeOf: features.
  s modules
    do: [| :each coverage |
         coverage := each exports intersection: features.
         coverage isEmpty
           ifFalse: [module requirements include: each.
                     covered includeAll: coverage]].
  module requirements
].

s@(System traits) add: module
[
  s modules include: module.
  s fillRequirementsFor: module.
  module
].

s@(System traits) build
"Compile the System's modules."
[
  s modules do: #build`er.
].

s@(System traits) load
"Load the System's modules in a consistent order."
[| remaining |
  remaining := s modules copy.
  [remaining isEmpty]
    whileFalse:
      [remaining do:
        [| :each |
         (features includesAllOf: each requirements)
                 ifTrue: [each load. remaining remove: each]]].
].

s@(System traits) load: module
"Loads the given module and recursively re-loads modules that depend upon it."
[
  module load.
  s modules
    do: [| :each | (each dependsOn: module) ifTrue: [s load: each]].
].

systems define: #Core &builder: [System newForAll: globals modules].
"This relies on being loaded just after all the standard libraries, and more
importantly before other systems."