Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
Hayley Patton
netfarm
Commits
8387410b
Commit
8387410b
authored
Feb 27, 2020
by
Hayley Patton
🐢
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Separate MOP client code, remove remains of ancient Netfarm designs and "checkpointing"
parent
4f468fc3
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
84 additions
and
136 deletions
+84
-136
Code/Objects/MOP/netfarm-class.lisp
Code/Objects/MOP/netfarm-class.lisp
+7
-74
Code/Objects/MOP/netfarm-slot.lisp
Code/Objects/MOP/netfarm-slot.lisp
+69
-0
Code/Objects/checkpointing.lisp
Code/Objects/checkpointing.lisp
+0
-16
Code/conditions.lisp
Code/conditions.lisp
+0
-43
Code/netfarm.asd
Code/netfarm.asd
+8
-3
No files found.
Code/Objects/
mop
.lisp
→
Code/Objects/
MOP/netfarm-class
.lisp
View file @
8387410b
(
in-package
:netfarm
)
;;; The new, MOP-backed, Netfarm object implementation.
(
defgeneric
netfarm-class-scripts
(
class
)
(
:method
((
class
standard-class
))
'
()))
(
defgeneric
netfarm-class-message-script
(
class
)
...
...
@@ -9,6 +7,8 @@
(
defgeneric
netfarm-class-presentation-script
(
class
)
(
:method
((
class
standard-class
))
nil
))
;;; The new, MOP-backed, Netfarm object implementation.
(
defclass
netfarm-class
(
standard-class
)
((
presentation-script
:initform
nil
:initarg
:presentation-script
...
...
@@ -73,50 +73,11 @@ Providing the class option (:scripts script ...) will attach the initialisation
(
:method
((
class
netfarm-class
))
(
hash-object*
(
class->schema
class
))))
(
defclass
netfarm-slot
(
closer-mop:standard-direct-slot-definition
)
((
computed
:initarg
:computed
:initform
nil
)
(
documentation
:initarg
:documentation
:reader
slot-documentation
)
(
netfarm-name
:initarg
:netfarm-name
:reader
slot-netfarm-name
)))
(
defmethod
print-object
((
slot
netfarm-slot
)
stream
)
(
print-unreadable-object
(
slot
stream
:type
t
)
(
format
stream
"~s"
(
slot-netfarm-name
slot
))))
(
defclass
netfarm-computed-slot
(
netfarm-slot
)
())
(
defmethod
initialize-instance
:around
((
slot
netfarm-computed-slot
)
&rest
rest
&key
initform
name
)
(
unless
(
null
initform
)
(
error
"Cannot supply an initform for the computed slot ~s"
name
))
(
apply
#'
call-next-method
slot
:initform
'
()
:initfunction
(
constantly
'
())
rest
))
(
defmethod
initialize-instance
:after
((
slot
netfarm-slot
)
&key
)
;; Generate a netfarm-slot name from the slot's symbol-name.
(
unless
(
slot-boundp
slot
'netfarm-name
)
(
setf
(
slot-value
slot
'netfarm-name
)
(
string-downcase
(
closer-mop:slot-definition-name
slot
)))))
(
defmethod
closer-mop:direct-slot-definition-class
((
class
netfarm-class
)
&rest
initargs
)
(
declare
(
ignore
class
))
(
destructuring-bind
(
&key
computed
&allow-other-keys
)
initargs
(
if
computed
(
find-class
'netfarm-computed-slot
)
(
find-class
'netfarm-slot
))))
(
macrolet
((
mht
()
'
(
make-hash-table
:test
'equal
)))
(
defclass
object
()
((
signatures
:initarg
:signatures
:initform
nil
:accessor
object-signatures
)
(
metadata
:initform
(
mht
)
:initarg
:metadata
:reader
object-metadata
)
(
source
:initarg
:source
:initform
nil
:accessor
object-source
)
(
last-hash
:initform
nil
:accessor
object-last-hash
))))
(
defclass
object
()
((
metadata
:initarg
:metadata
:initform
(
make-hash-table
:test
'equal
)
:reader
object-metadata
)
(
signatures
:initarg
:signatures
:initform
nil
:accessor
object-signatures
)
(
source
:initarg
:source
:initform
nil
:accessor
object-source
)))
(
defmethod
closer-mop:class-direct-superclasses
((
class
netfarm-class
))
(
append
(
remove
(
find-class
'standard-object
)
(
call-next-method
))
...
...
@@ -172,31 +133,3 @@ Providing the class option (:scripts script ...) will attach the initialisation
(
maybe-add-class-slots
class
))
(
setf
(
slot-value
class
'slot-table
)
slot-table
(
slot-value
class
'computed-slot-table
)
computed-slot-table
))))
(
declaim
(
inline
find-netfarm-slot
map-slots
find-netfarm-computed-slot
map-computed-slots
))
(
defun
find-netfarm-slot
(
class
slot-name
)
(
etypecase
slot-name
(
symbol
(
setf
slot-name
(
string-downcase
slot-name
)))
(
string
))
(
string-gethash
(
netfarm-class-slot-table
class
)
slot-name
))
(
defun
map-slots
(
function
class
)
"Call the function with each slot name and definition in the class."
(
let
((
table
(
netfarm-class-slot-table
class
)))
(
loop
for
bucket
across
table
do
(
loop
for
(
name
.
definition
)
in
bucket
do
(
funcall
function
name
definition
)))))
(
defun
find-netfarm-computed-slot
(
class
slot-name
)
(
etypecase
slot-name
(
symbol
(
setf
slot-name
(
string-downcase
slot-name
)))
(
string
))
(
string-gethash
(
netfarm-class-computed-slot-table
class
)
slot-name
))
(
defun
map-computed-slots
(
function
class
)
"Call the function with each computed slot name and definition in the class."
(
let
((
table
(
netfarm-class-computed-slot-table
class
)))
(
loop
for
bucket
across
table
do
(
loop
for
(
name
.
definition
)
in
bucket
do
(
funcall
function
name
definition
)))))
Code/Objects/MOP/netfarm-slot.lisp
0 → 100644
View file @
8387410b
(
in-package
:netfarm
)
(
defclass
netfarm-slot
(
closer-mop:standard-direct-slot-definition
)
((
computed
:initarg
:computed
:initform
nil
)
(
documentation
:initarg
:documentation
:reader
slot-documentation
)
(
netfarm-name
:initarg
:netfarm-name
:reader
slot-netfarm-name
)))
(
defmethod
print-object
((
slot
netfarm-slot
)
stream
)
(
print-unreadable-object
(
slot
stream
:type
t
)
(
format
stream
"~s"
(
slot-netfarm-name
slot
))))
(
defclass
netfarm-computed-slot
(
netfarm-slot
)
())
(
defmethod
initialize-instance
:around
((
slot
netfarm-computed-slot
)
&rest
rest
&key
initform
name
)
(
unless
(
null
initform
)
(
error
"Cannot supply an initform for the computed slot ~s"
name
))
(
apply
#'
call-next-method
slot
:initform
'
()
:initfunction
(
constantly
'
())
rest
))
(
defmethod
initialize-instance
:after
((
slot
netfarm-slot
)
&key
)
;; Generate a netfarm-slot name from the slot's symbol-name.
(
unless
(
slot-boundp
slot
'netfarm-name
)
(
setf
(
slot-value
slot
'netfarm-name
)
(
string-downcase
(
closer-mop:slot-definition-name
slot
)))))
(
defmethod
closer-mop:direct-slot-definition-class
((
class
netfarm-class
)
&rest
initargs
)
(
declare
(
ignore
class
))
(
destructuring-bind
(
&key
computed
&allow-other-keys
)
initargs
(
if
computed
(
find-class
'netfarm-computed-slot
)
(
find-class
'netfarm-slot
))))
(
declaim
(
inline
find-netfarm-slot
map-slots
find-netfarm-computed-slot
map-computed-slots
))
(
defun
find-netfarm-slot
(
class
slot-name
)
"Find the effective slot definition for a Netfarm slot."
(
etypecase
slot-name
(
symbol
(
setf
slot-name
(
string-downcase
slot-name
)))
(
string
))
(
string-gethash
(
netfarm-class-slot-table
class
)
slot-name
))
(
defun
map-slots
(
function
class
)
"Call the function with each slot name and effective slot definition in the class."
(
let
((
table
(
netfarm-class-slot-table
class
)))
(
loop
for
bucket
across
table
do
(
loop
for
(
name
.
definition
)
in
bucket
do
(
funcall
function
name
definition
)))))
(
defun
find-netfarm-computed-slot
(
class
slot-name
)
"Find the effective slot definition for a Netfarm computed slot."
(
etypecase
slot-name
(
symbol
(
setf
slot-name
(
string-downcase
slot-name
)))
(
string
))
(
string-gethash
(
netfarm-class-computed-slot-table
class
)
slot-name
))
(
defun
map-computed-slots
(
function
class
)
"Call the function with each computed slot name and definition in the class."
(
let
((
table
(
netfarm-class-computed-slot-table
class
)))
(
loop
for
bucket
across
table
do
(
loop
for
(
name
.
definition
)
in
bucket
do
(
funcall
function
name
definition
)))))
Code/Objects/checkpointing.lisp
deleted
100644 → 0
View file @
4f468fc3
(
in-package
:netfarm
)
;;; A kind of "checkpointing" system where we can ask if an object has been
;;; updated since it was last saved, and update the last hash it had when it
;;; gets updated.
(
defun
object-changed-p
(
object
)
(
check-type
object
object
)
(
or
(
null
(
object-last-hash
object
))
(
some
#'
/=
(
hash-object
object
)
(
object-last-hash
object
))))
(
defun
object-set-checkpoint
(
object
)
(
setf
(
object-last-hash
object
)
(
hash-object
object
)))
Code/conditions.lisp
deleted
100644 → 0
View file @
4f468fc3
(
in-package
:netfarm
)
(
define-condition
parser-error
(
error
)
((
name
:initarg
:name
:reader
parser-error-name
))
(
:report
(
lambda
(
condition
stream
)
(
format
stream
"~s could not be parsed"
(
parser-error-name
condition
)))))
(
define-condition
parser-bad-segment-count
(
parser-error
)
((
count
:initarg
:count
:reader
parser-error-segment-count
))
(
:report
(
lambda
(
condition
stream
)
(
format
stream
"~d segment~:p ~:*~[were~;was~;were~] provided, not 3 or 4"
(
parser-error-segment-count
condition
)))))
(
define-condition
parser-empty-line
(
parser-error
)
((
key
:initarg
:key
:reader
parser-error-key
))
(
:report
(
lambda
(
condition
stream
)
(
format
stream
"The key ~a was provided with no values"
(
render
(
parser-error-key
condition
))))))
(
define-condition
parser-bad-signature
(
parser-error
)
((
signature
:initarg
:signature
:reader
parser-bad-signature-signature
))
(
:report
(
lambda
(
condition
stream
)
(
format
stream
"The signature given is invalid: ~s"
(
parser-bad-signature-signature
condition
)))))
(
define-condition
parser-codecs-in-key
(
parser-error
)
((
atom
:initarg
:atom
:reader
parser-error-key
))
(
:report
(
lambda
(
condition
stream
)
(
format
stream
"A codec was encountered in a slot name: ~s"
(
parser-error-key
condition
)))))
(
define-condition
schema-error
()
())
(
define-condition
netfarm-slot-missing
(
schema-error
)
((
instance
:initarg
:instance
:reader
schema-slot-missing-instance
)
(
slot-name
:initarg
:slot-name
:reader
schema-slot-missing-slot-name
))
(
:report
(
lambda
(
condition
stream
)
(
format
stream
"The slot ~s is missing in ~s"
(
schema-slot-missing-slot-name
condition
)
(
schema-slot-missing-instance
condition
)))))
Code/netfarm.asd
View file @
8387410b
...
...
@@ -6,13 +6,16 @@
:version
"0.1.0"
:components
((
:file
"package"
)
(
:file
"macros"
)
(
:file
"conditions"
)
(
:module
"Codecs"
:depends-on
(
"package"
"macros"
)
:components
((
:file
"base64"
)
(
:file
"codecs"
)))
(
:module
"Objects"
:depends-on
(
"package"
"macros"
)
:components
((
:file
"hash"
)
(
:file
"mop"
)
(
:module
"MOP"
:components
((
:file
"netfarm-class"
)
(
:file
"netfarm-slot"
)))
(
:file
"rewrite-references"
)
(
:file
"objects"
)
(
:file
"schema"
)
...
...
@@ -21,6 +24,7 @@
(
:file
"computed-values"
)
(
:file
"deep-copy"
)))
(
:module
"Scripts"
:depends-on
(
"Objects"
)
:components
((
:file
"package"
)
(
:module
"Script-machine"
:components
((
:file
"conditions"
)
...
...
@@ -35,10 +39,11 @@
(
:file
"assemble"
)
(
:file
"define-script"
)))))
(
:file
"Objects/inbuilt-schemas"
)
(
:file
"Objects/checkpointing"
)
(
:module
"Text-format"
:depends-on
(
"Codecs"
"Objects"
)
:components
((
:file
"new-parser"
)
(
:file
"new-renderer"
)))
(
:module
"Crypto"
:depends-on
(
"Text-format"
)
:components
((
:file
"hash"
)
(
:file
"keys"
:depends-on
(
"hash"
))))))
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment