Try reintroducing data grammars
author |
Steve Losh <steve@stevelosh.com> |
date |
Sat, 14 Jan 2017 16:12:51 +0000 |
parents |
5df9219aa0d3
|
children |
07621aaf57e2
|
branches/tags |
(none) |
files |
examples/git-commands.lisp src/chancery.lisp |
Changes
--- a/examples/git-commands.lisp Fri Jan 13 00:07:56 2017 +0000
+++ b/examples/git-commands.lisp Sat Jan 14 16:12:51 2017 +0000
@@ -1,7 +1,7 @@
(in-package :chancery)
(named-readtables:in-readtable :chancery)
-(define-rule noun
+(define-string noun
"binary blob"
"packfile"
"refspec"
@@ -21,11 +21,10 @@
"repository"
"symlink"
"tag"
- "tip"
- )
+ "tip")
-(define-rule git-location%
+(define-string git-location%
"repository"
"index"
"working tree"
@@ -39,7 +38,7 @@
"upstream repository"
"DAG")
-(define-rule git-folder%
+(define-string git-folder%
""
"refs"
"logs"
@@ -48,14 +47,14 @@
"HEAD"
"COMMIT_EDITMSG")
-(define-rule git-folder
+(define-string git-folder
(".git/" :. git-folder%))
-(define-rule git-location
+(define-string git-location
("the" git-location%)
git-folder)
-(define-rule external-location
+(define-string external-location
"Hacker News"
"Stack Overflow"
"Twitter"
@@ -70,12 +69,12 @@
"the git source code"
"your home directory")
-(define-rule location
+(define-string location
git-location
external-location)
-(define-rule action
+(define-string action
(list "bisect" "bisecting")
(list "clone" "cloning")
(list "commit" "committing")
@@ -99,23 +98,22 @@
(list "sign" "signing")
(list "simplify" "simplifying")
(list "update" "updating")
- (list "verify" "verifying")
- )
+ (list "verify" "verifying"))
(defun action-verb ()
(first (action)))
-(define-rule refresh
+(define-string refresh
"update"
"reset")
-(define-rule refreshing
+(define-string refreshing
"updating"
"resetting")
-(define-rule extremum
+(define-string extremum
"newest"
"oldest"
"largest"
@@ -127,7 +125,7 @@
"simplest"
"best")
-(define-rule adjective
+(define-string adjective
"merged"
"unmerged"
"symbolic"
@@ -137,62 +135,61 @@
"big-endian"
"little-endian"
"childless"
- "binary"
- )
+ "binary")
-(define-rule age
+(define-string age
"newest"
"oldest"
"first"
"last")
-(define-rule look-for
+(define-string look-for
"search"
"grep"
"bisect"
"filter")
-(define-rule temporal-adverb
+(define-string temporal-adverb
"before"
"after"
"without")
(defun letter ()
- (random-elt "abcdefghijklmnopqrstuvwxyz"))
+ (random-elt "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
(defun shellify (str)
(string-downcase (substitute #\- #\space str)))
-(define-rule short-option%
+(define-string short-option%
("-" :. letter)
("-" :. letter [noun shellify string-upcase]))
(defparameter *noun* nil)
-(define-rule long-option%
- (eval (let ((*noun* (generate [noun shellify])))
- (generate ("--" :. *noun* :. "=<" :. *noun* :. ">"))))
+(define-string long-option%
+ (eval (let ((*noun* (generate-string [noun shellify])))
+ (generate-string ("--" :. *noun* :. "=<" :. *noun* :. ">"))))
("--" :. action-verb)
("--" :. extremum)
("--only-" :. adjective)
("--only-" :. [noun shellify s])
("--" :. action-verb :. "=<" :. [noun shellify] :. ">"))
-(define-rule short-option
+(define-string short-option
short-option%
("[" :. short-option% :. "]"))
-(define-rule long-option
+(define-string long-option
long-option%
("[" :. long-option% :. "]"))
-(define-rule short-options
+(define-string short-options
short-option
(short-option short-option))
-(define-rule options
+(define-string options
long-option
short-options
(short-options long-option)
@@ -202,7 +199,7 @@
(defparameter *command* nil)
(defparameter *commanding* nil)
-(define-rule description
+(define-string description
(look-for location "for the" age noun "and" *command* "it")
("read" (eval (+ 2 (random 2000))) "bytes from" location "and" *command* "them")
(*command* "the" extremum noun "in" git-location)
@@ -219,8 +216,8 @@
(defun entry ()
(destructuring-bind (*command* *commanding*) (action)
- (generate
+ (generate-string
("git" *command* options #\newline :. [description cap]))))
-(dotimes (_ 20) (princ (entry)) (terpri) (terpri))
+; (dotimes (_ 20) (princ (entry)) (terpri) (terpri))
--- a/src/chancery.lisp Fri Jan 13 00:07:56 2017 +0000
+++ b/src/chancery.lisp Sat Jan 14 16:12:51 2017 +0000
@@ -47,17 +47,21 @@
(apply #'append <>)))
-;;;; Guts ---------------------------------------------------------------------
-(defun evaluate-combination (list)
- (-<> list
- (separate-with-spaces <>)
- (mapcar #'evaluate-expression <>)
- (apply #'cat (mapcar #'princ-to-string <>))))
+(deftype non-keyword-symbol ()
+ '(and symbol (not keyword)))
+
-(defun evaluate-modifiers (vector)
- (reduce (flip #'funcall) vector
- :start 1
- :initial-value (evaluate-expression (aref vector 0))))
+;;;; Data ---------------------------------------------------------------------
+(defun data-special-form-p (form)
+ (ensure-boolean (and (consp form)
+ (member (first form) '(quote eval)))))
+
+(deftype data-special-form ()
+ '(satisfies data-special-form-p))
+
+
+(defun evaluate-sequence (seq)
+ (map (type-of seq) #'evaluate-expression seq))
(defun evaluate-symbol (symbol)
(if (fboundp symbol)
@@ -67,25 +71,78 @@
(defun evaluate-lisp (expr)
(eval expr))
+(defun evaluate-data-special-form (expr)
+ (destructuring-bind (symbol argument) expr
+ (ecase symbol
+ (quote argument)
+ (eval (evaluate-lisp argument)))))
-(defun evaluate-list (list)
- (mapcar #'evaluate-expression list))
(defun evaluate-expression (expr)
(typecase expr
- ((or string keyword null) expr)
- (symbol (evaluate-symbol expr))
- (vector (evaluate-modifiers expr))
- (cons (case (first expr)
- (quote (second expr))
- (eval (evaluate-lisp (second expr)))
- (list (evaluate-list (rest expr)))
- (t (evaluate-combination expr))))
+ (non-keyword-symbol (evaluate-symbol expr))
+ (data-special-form (evaluate-data-special-form expr))
+ (string expr)
+ (sequence (evaluate-sequence expr))
(t expr)))
(defmacro define-rule (name &rest expressions)
- "Define a Chancery rule for the symbol `name`.
+ `(defun ,name ()
+ (evaluate-expression
+ (random-elt ,(coerce expressions 'vector)))))
+
+(defmacro generate (expression)
+ "Generate a single Chancery expression."
+ `(evaluate-expression ',expression))
+
+
+;;;; Strings ------------------------------------------------------------------
+(defun string-special-form-p (form)
+ (ensure-boolean (and (consp form)
+ (member (first form) '(quote eval list vector)))))
+
+(deftype string-special-form ()
+ '(satisfies string-special-form-p))
+
+
+(defun evaluate-string-combination (list)
+ (-<> list
+ (separate-with-spaces <>)
+ (mapcar #'evaluate-string-expression <>)
+ (apply #'cat (mapcar #'princ-to-string <>))))
+
+(defun evaluate-string-modifiers (vector)
+ (reduce (flip #'funcall) vector
+ :start 1
+ :initial-value
+ (princ-to-string (evaluate-string-expression (aref vector 0)))))
+
+(defun evaluate-string-sequence (sequence-type seq)
+ (map sequence-type #'evaluate-string-expression seq))
+
+(defun evaluate-string-special-form (expr)
+ (destructuring-bind (symbol . body) expr
+ (ecase symbol
+ (quote (first body))
+ (list (evaluate-string-sequence 'list body))
+ (vector (evaluate-string-sequence 'vector body))
+ (eval (evaluate-lisp (first body))))))
+
+
+(defun evaluate-string-expression (expr)
+ (typecase expr
+ (string expr)
+ (null "")
+ (non-keyword-symbol (evaluate-symbol expr))
+ (string-special-form (evaluate-string-special-form expr))
+ (vector (evaluate-string-modifiers expr))
+ (cons (evaluate-string-combination expr))
+ (t expr)))
+
+
+(defmacro define-string (name &rest expressions)
+ "Define a Chancery string rule for the symbol `name`.
Each expression in `expressions` can be any valid Chancery expression. When
the rule is invoked one will be chosen at random and evaluated.
@@ -102,12 +159,12 @@
"
`(defun ,name ()
- (evaluate-expression
+ (evaluate-string-expression
(random-elt ,(coerce expressions 'vector)))))
-(defmacro generate (expression)
- "Generate a single Chancery expression."
- `(evaluate-expression ',expression))
+(defmacro generate-string (expression)
+ "Generate a single Chancery string expression."
+ `(evaluate-string-expression ',expression))
;;;; Modifiers ----------------------------------------------------------------