diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-09 21:50:15 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-09 21:52:51 +0200 |
commit | 8a90e2e7e03f10ebdab394a16893f09a25e29af9 (patch) | |
tree | 9db9779c51b0819927c868215cb1b22a21b5c6e9 | |
parent | work. (diff) | |
parent | Document type and object system. (diff) | |
download | calp-8a90e2e7e03f10ebdab394a16893f09a25e29af9.tar.gz calp-8a90e2e7e03f10ebdab394a16893f09a25e29af9.tar.xz |
Merge typecheck macro into c-parser.
Merge branch 'new-object-system' into c-parser
-rw-r--r-- | doc/ref/guile.texi | 2 | ||||
-rw-r--r-- | doc/ref/guile/util-object.texi | 86 | ||||
-rw-r--r-- | doc/ref/guile/util-type.texi | 62 | ||||
-rw-r--r-- | module/c/cpp-environment.scm | 1 | ||||
-rw-r--r-- | module/c/cpp-environment/function-like-macro.scm | 1 | ||||
-rw-r--r-- | module/hnh/util/object.scm | 21 | ||||
-rw-r--r-- | module/hnh/util/type.scm | 46 |
7 files changed, 199 insertions, 20 deletions
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index a6c5ebe4..58c162e1 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -7,6 +7,8 @@ @include guile/util.texi @include guile/util-path.texi @include guile/util-config.texi +@include guile/util-type.texi +@include guile/util-object.texi @include guile/base64.texi @include guile/web.texi @include guile/vcomponent.texi diff --git a/doc/ref/guile/util-object.texi b/doc/ref/guile/util-object.texi new file mode 100644 index 00000000..ceac2f2a --- /dev/null +++ b/doc/ref/guile/util-object.texi @@ -0,0 +1,86 @@ +@node define-type +@section Yet Another Object System + +@defmac define-type (name type-parameters ...) fields ... +Introduce a new type. + +Each field is either a symbol, or a list where the first element is a +symbol, and the remaining elements are alternating keywords and +values, as per @ref{Field Parameters}. All fields are optional by +default, but can be made non-optional through its type parameter. + +The example below creates a new type called @var{type}, with a custom +printer which always displays the string ``TYPE''. It has two fields, +@var{x}, which must be an integer, and @var{y}, which can have any +type, but gets the value ``Hello'' in none is given. +@example +(define-type (type #:printer (lambda (r p) (display "TYPE" p))) + (x #:type integer?) + (y #:default "Hello")) +@end example +@end defmac + +@subsection Type Parameters + +@deffn {Type Parameter} constructor (λ (primitive-constructor type-validator)) +Use a custom constructor for the type. The given procedure is called +with two values: +@itemize +@item the types primitive (and usually hidden) constructor, +which takes as many arguments as there are fields, in the order given +in define-type, and +@item the type validator procedure, which also takes all arguments, +but instead either returns an undefined value if everything is fine, +or throws @code{'wrong-type-arg} otherwise. +@end itemize +The procedure should then return a new procedure, which will be bound +as the constructor for the type. Note that default values are current +disregarded with custom constructors. + +A custom constructor for the type above might look like +@example +(lambda (primitive-constructor type-check) + (lambda* (#:key x y) + (type-check x y) + (primitive-constructor x y))) +@end example +@end deffn + +@deffn {Type Parameter} printer (λ (record port)) +Use a custom printer for the type. +@end deffn + +@subsection Field Parameters +@anchor{Field Parameters} + +@deffn {Field Parameter} default value +Value the field should get if not given. +@end deffn + +@deffn {Field Parameter} type type-clause +A type predicate that the field must obey. See @ref{type-clause} for details. +@end deffn + +@subsection Introduced Bindings + +Define type introduces a number procedures. (@var{<name>} should be +replaced with whatever was given as @var{name} to define-type. + +@defun @var{<name>} [kv-args ...] +Type constructor. Takes key-value arguments. Where the keys are the +names of the fields. +@end defun + +@defun @var{<name>}? x +Type predicate. +@end defun + +And for each field @var{<field>}: + +@defun @var{<field>} object [value] +Accessor for the given filed. +Returns the current value if called with only an object, and returns a +new object with @var{field} set to @var{value} if called with two values. + +The updating version checks the type if #:type was given on creation. +@end defun diff --git a/doc/ref/guile/util-type.texi b/doc/ref/guile/util-type.texi new file mode 100644 index 00000000..104b00b3 --- /dev/null +++ b/doc/ref/guile/util-type.texi @@ -0,0 +1,62 @@ +@node Type utilities +@section Type utilities + +Provided by the module @code{(hnh util type)} + +@subsection Type Clauses +@anchor{type-clause} +@cindex type-clause + +Type clauses are an effective way of writing compound predicates +without explicitly mentioning the variable at all steps. + +The simplest type predicate is a single symbol, which is directly +called on the object: +@example +predicate? ⇒ (predicate? x) +@end example + +Otherwise, if the predicate is a list then the variable is spliced +into the argument list in the first position: +@example +(proc args ...) ⇒ (proc x args ...) +@end example + +The two primitives @code{and} and @code{or} are also available, which +both take an arbitrary number of predicates, and calls them in order, +with Scheme's usual short-circuiting rules. +@footnote{@code{and} and @code{or} doesn't have to be primitives, but +we would otherwise have one hell of a namespace conflict} + +@defmac list-of variable type-clause +Checks if @var{variable} is a list, and that every element satisfies type-clause. +@end defmac + +@defmac pair-of variable car-type-clause cdr-type-clause +Check if @var{variable} is a cons-pair, and that the car satisfies +@var{car-type-clause}, and that the cdr satisfies @var{cdr-type-clause}. +@end defmac + +@subsection Deffinitions + +@defmac build-validator-body variable type-clause +``Entry point'' of type clauses. Inserts variable into the +type-clause, returning something ready to be passed along the eval (or +rather, spliced into another macro). + +Also used if new ``primitives'' are to be added, such as list-of. +@end defmac + +@defmac typecheck variable type-clause [procedure-name=(current-procedure-name)] +Checks @var{variable} against @var{type-clause}, and raises +@code{'wrong-type-argument} if it fails. @var{procedure-name} is used +as the calling procedure for @code{scm-error}. + +Useful at the start of procedures. +@end defmac + + +@defmac current-procedure-name +Returns the current procedure name as a symbol, or @code{#f} if not found. +@end defmac + diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm index 3ce754df..d6c86f7a 100644 --- a/module/c/cpp-environment.scm +++ b/module/c/cpp-environment.scm @@ -3,6 +3,7 @@ :use-module (srfi srfi-88) :use-module (ice-9 hash-table) :use-module (hnh util object) + :use-module (hnh util type) :use-module (hnh util lens) :use-module ((c cpp-environment function-like-macro) :prefix #{fun:}#) :use-module ((c cpp-environment object-like-macro) :prefix #{obj:}#) diff --git a/module/c/cpp-environment/function-like-macro.scm b/module/c/cpp-environment/function-like-macro.scm index 0a0611e3..26512439 100644 --- a/module/c/cpp-environment/function-like-macro.scm +++ b/module/c/cpp-environment/function-like-macro.scm @@ -1,5 +1,6 @@ (define-module (c cpp-environment function-like-macro) :use-module (hnh util object) + :use-module (hnh util type) :export (function-like-macro function-like-macro? identifier diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm index 4dbb45a8..4477b462 100644 --- a/module/hnh/util/object.scm +++ b/module/hnh/util/object.scm @@ -1,8 +1,8 @@ (define-module (hnh util object) - :use-module (srfi srfi-1) :use-module (srfi srfi-9 gnu) :use-module (ice-9 curried-definitions) :use-module (hnh util) + :use-module (hnh util type) :export (define-type)) @@ -35,25 +35,6 @@ -;; DSL for specifying type predicates -;; Basically a procedure body, but the variable to test is implicit. -(define-syntax build-validator-body - (syntax-rules (and or list-of) - ((_ variable (and clauses ...)) (and (build-validator-body variable clauses) ...)) - ((_ variable (or clauses ...)) (or (build-validator-body variable clauses) ...)) - ((_ variable (list-of (proc args ...))) - (and (list? variable) - (every (lambda (x) (build-validator-body x (proc args ...))) - variable))) - ((_ variable (list-of proc)) (and (list? variable) - (every proc variable))) - ((_ variable (pair-of a b)) (and (pair? variable) - (build-validator-body (car variable) a) - (build-validator-body (cdr variable) b))) - ((_ variable (proc args ...)) (proc variable args ...)) - ((_ variable proc) (proc variable)))) - - ;; Given (x type: predicate?), expand to a single `unless' form (otherwise #f) (define-syntax (validator stx) (syntax-case stx () diff --git a/module/hnh/util/type.scm b/module/hnh/util/type.scm new file mode 100644 index 00000000..800834e5 --- /dev/null +++ b/module/hnh/util/type.scm @@ -0,0 +1,46 @@ +(define-module (hnh util type) + :use-module ((srfi srfi-1) :select (every)) + :export (build-validator-body + list-of pair-of + typecheck + current-procedure-name)) + +(define-syntax list-of + (syntax-rules () + ((_ variable (rule ...)) + (and (list? variable) + (every (lambda (x) (build-validator-body x (rule ...))) variable))) + ((_ variable rule) + (and (list? variable) + (every rule variable))))) + +(define-syntax-rule (pair-of variable a b) + (and (pair? variable) + (build-validator-body (car variable) a) + (build-validator-body (cdr variable) b))) + +;; DSL for specifying type predicates +;; Basically a procedure body, but the variable to test is implicit. +(define-syntax build-validator-body + (syntax-rules (and or list-of) + ((_ variable (and clauses ...)) (and (build-validator-body variable clauses) ...)) + ((_ variable (or clauses ...)) (or (build-validator-body variable clauses) ...)) + ((_ variable (proc args ...)) (proc variable args ...)) + ((_ variable proc) (proc variable)))) + +(define-syntax-rule (current-procedure-name) + ;; 1 since make-stack is at top of stack + (frame-procedure-name (stack-ref (make-stack #t) 1))) + +(define-syntax typecheck + (syntax-rules () + ((_ variable type-clause) + (let ((procedure-name (current-procedure-name))) + (typecheck variable type-clause procedure-name))) + ((_ variable type-clause procedure-name) + (unless (build-validator-body variable type-clause) + (scm-error 'wrong-type-arg procedure-name + "Invalid value for ~s. Expected ~s, got ~s" + (list (quote variable) (quote type-clause) variable) + #f))))) + |