|
|
@@ -0,0 +1,246 @@
|
|
|
+;;; This file contains modified code from cl-m4 that demonstrates how graylex
|
|
|
+;;; can be used. If you want a full-fledged example including recursive descent
|
|
|
+;;; parsing, please checkout http://github.com/e-user/cl-m4
|
|
|
+
|
|
|
+(defpackage example
|
|
|
+ (:use :cl :parser-combinators :alexandria))
|
|
|
+(in-package :example)
|
|
|
+
|
|
|
+(defun not-equal (a b)
|
|
|
+ (not (equal a b)))
|
|
|
+
|
|
|
+(defun <ml-not-end> ()
|
|
|
+ (named-seq? (<- char
|
|
|
+ (choice (sat (curry #'not-equal #\*))
|
|
|
+ (except? #\* "*/")))
|
|
|
+ (string char)))
|
|
|
+
|
|
|
+(defun <ml-content> (ml-comment)
|
|
|
+ (named-seq? (<- content
|
|
|
+ (many? (choice (named-seq? (<- inner ml-comment)
|
|
|
+ (concatenate 'string "/*" inner "*/"))
|
|
|
+ (<ml-not-end>))))
|
|
|
+ (apply #'concatenate 'string content)))
|
|
|
+
|
|
|
+(defun <ml-comment> ()
|
|
|
+ (named? ml-comment
|
|
|
+ (bracket? "/*" (<ml-content> ml-comment) "*/")))
|
|
|
+
|
|
|
+(defun <sl-comment> ()
|
|
|
+ (bracket? "//"
|
|
|
+ (named-seq? (<- comment (many? (sat (curry #'not-equal #\Newline))))
|
|
|
+ (coerce comment 'string))
|
|
|
+ #\Newline))
|
|
|
+
|
|
|
+(defun <punctuation> ()
|
|
|
+ (sat (rcurry #'member '(#\; #\( #\) #\{ #\} #\. #\# #\: #\[ #\] #\= #\? #\% #\+ #\< #\> #\, #\* #\!))))
|
|
|
+
|
|
|
+(defun <token> ()
|
|
|
+ (choice
|
|
|
+ (between? (sat #'(lambda (i) (or (alphanumericp i)
|
|
|
+ (member i '(#\_))))) 1 nil 'string)
|
|
|
+ (quoted? :quote-char #\`)))
|
|
|
+
|
|
|
+(defun strip-comments (input)
|
|
|
+ (apply #'concatenate 'string
|
|
|
+ (remove :comment
|
|
|
+ (substitute " " nil
|
|
|
+ (parse-string*
|
|
|
+ (many? (choices (<token>)
|
|
|
+ (named-seq? (<- p (<punctuation>)) (string p))
|
|
|
+ "---"
|
|
|
+ (whitespace?)
|
|
|
+ (named-seq? (<sl-comment>) :comment)
|
|
|
+ (named-seq? (<ml-comment>) :comment)))
|
|
|
+ input)))))
|
|
|
+
|
|
|
+;; Actual parser
|
|
|
+(defun <hex-digit> ()
|
|
|
+ (choice (digit?) (sat (rcurry #'member '(#\a #\b #\c #\d #\e #\f)))))
|
|
|
+
|
|
|
+(defun <letter> ()
|
|
|
+ (choice (lower?) (upper?)))
|
|
|
+
|
|
|
+(defun <ident-char> ()
|
|
|
+ (choices (<letter>) (digit?) #\_))
|
|
|
+
|
|
|
+(defun concat (&rest args)
|
|
|
+ (apply #'concatenate 'string args))
|
|
|
+
|
|
|
+(defun string-concat (args)
|
|
|
+ (apply #'concatenate 'string (mapcar 'string args)))
|
|
|
+
|
|
|
+(defun <lc-ident> ()
|
|
|
+ (named-seq? (<- hd (lower?))
|
|
|
+ (<- tl (many? (<ident-char>)))
|
|
|
+ (coerce (cons hd tl) 'string)))
|
|
|
+
|
|
|
+(defun <uc-ident> ()
|
|
|
+ (named-seq? (<- hd (upper?))
|
|
|
+ (<- tl (many? (<ident-char>)))
|
|
|
+ (coerce (cons hd tl) 'string)))
|
|
|
+
|
|
|
+(defun <namespace-ident> () (<lc-ident>))
|
|
|
+
|
|
|
+(defun <lc-ident-ns> ()
|
|
|
+ (named-seq? (<- ns (opt? (seq-list? (<namespace-ident>) #\.)))
|
|
|
+ (<- id (<lc-ident>))
|
|
|
+ (concat (when ns (string-concat ns)) id)))
|
|
|
+
|
|
|
+(defun <uc-ident-ns> ()
|
|
|
+ (named-seq? (<- ns (opt? (seq-list? (<namespace-ident>) #\.)))
|
|
|
+ (<- id (<uc-ident>))
|
|
|
+ (concat (when ns (string-concat ns)) id)))
|
|
|
+
|
|
|
+(defun <lc-ident-full> ()
|
|
|
+ (named-seq? (<- id (<lc-ident-ns>))
|
|
|
+ (<- name (opt? (seq-list? #\# (times? (<hex-digit>) 8))))
|
|
|
+ (concat id (when name (coerce (apply #'cons name) 'string)))))
|
|
|
+
|
|
|
+(defun <nat-const> ()
|
|
|
+ (many1? (digit?)))
|
|
|
+
|
|
|
+(defun <boxed-type-ident> () (<uc-ident-ns>))
|
|
|
+
|
|
|
+(defun sep? (&optional accept-empty) (whitespace? :accept-empty accept-empty))
|
|
|
+
|
|
|
+(defun <full-combinator-id> ()
|
|
|
+ (choice (<lc-ident-full>) "_"))
|
|
|
+
|
|
|
+(defun <combinator-id> ()
|
|
|
+ (choice (<lc-ident-ns>) "_"))
|
|
|
+
|
|
|
+(defun <type-ident> ()
|
|
|
+ (choices
|
|
|
+ (<boxed-type-ident>)
|
|
|
+ (<lc-ident-ns>)
|
|
|
+ "#"))
|
|
|
+
|
|
|
+(defun <var-ident> ()
|
|
|
+ (choice (<lc-ident>) (<uc-ident>)))
|
|
|
+
|
|
|
+(defun <term> (expr)
|
|
|
+ (named? term
|
|
|
+ (choices
|
|
|
+ (seq-list? "(" expr ")")
|
|
|
+ (<type-ident>)
|
|
|
+ (<var-ident>)
|
|
|
+ (<nat-const>)
|
|
|
+ (seq-list? "%" term)
|
|
|
+ (seq-list? (<type-ident>) "<" (sepby1? expr ",") ">")
|
|
|
+ )))
|
|
|
+
|
|
|
+(defun <subexpr> (expr)
|
|
|
+ (named? subexpr
|
|
|
+ (choices
|
|
|
+ (<term> expr)
|
|
|
+ (seq-list? (<nat-const>) "+" subexpr)
|
|
|
+ (seq-list? subexpr "+" (<nat-const>)))))
|
|
|
+
|
|
|
+(defun <expr> ()
|
|
|
+ (named? expr
|
|
|
+ (many? (<subexpr> expr))))
|
|
|
+
|
|
|
+(defun <type-expr> () (<expr>))
|
|
|
+(defun <nat-expr> () (<expr>))
|
|
|
+(defun <type-term> () (<term> (<expr>)))
|
|
|
+(defun <nat-term> () (<term> (<expr>)))
|
|
|
+
|
|
|
+(defun <opt-args> ()
|
|
|
+ (named-seq?
|
|
|
+ "{" (sep? t)
|
|
|
+ (<- vars (sepby1? (<var-ident>) (sep?))) (sep? t)
|
|
|
+ ":"
|
|
|
+ (opt? "!")
|
|
|
+ (<- type-expr (<type-expr>)) (sep? t)
|
|
|
+ "}" (sep? t)
|
|
|
+ (list :opt-args vars type-expr)))
|
|
|
+
|
|
|
+(defun <multiplicity> () (<nat-term>))
|
|
|
+(defun <var-ident-opt> () (choices (<var-ident>) "_"))
|
|
|
+(defun <conditional-def> ()
|
|
|
+ (seq-list? (<var-ident>) (opt? (seq-list? "." (<nat-const>))) "?"))
|
|
|
+
|
|
|
+(defun <args> ()
|
|
|
+ (named? args
|
|
|
+ (choices
|
|
|
+ (seq-list? (<var-ident-opt>) ":" (opt? (<conditional-def>)) (opt? "!") (<type-term>))
|
|
|
+ (seq-list? (opt? (seq-list? (<var-ident-opt>) ":"))
|
|
|
+ (opt? (seq-list? (<multiplicity>) "*"))
|
|
|
+ "[" (many? args) "]")
|
|
|
+ (seq-list? "(" (many1? (<var-ident-opt>)) ":" (opt? "!") (<type-term>) ")")
|
|
|
+ (seq-list? (opt? "!") (<type-term>)))))
|
|
|
+
|
|
|
+(defun <result-type> ()
|
|
|
+ (choices
|
|
|
+ (seq-list? (<boxed-type-ident>) (many? (<subexpr> (<expr>))))
|
|
|
+ (seq-list? (<boxed-type-ident>) "<" (sepby1? (<subexpr> (<expr>)) ",") ">")))
|
|
|
+
|
|
|
+(defun <combinator-decl> ()
|
|
|
+ (named-seq?
|
|
|
+ (<- comb (<full-combinator-id>)) (sep?)
|
|
|
+ (<- opt-args (many? (<opt-args>))) (sep? t)
|
|
|
+ (<- args (many? (<args>))) (sep? t)
|
|
|
+ "=" (sep?)
|
|
|
+ (<- result-type (<result-type>)) (sep? t)
|
|
|
+ ";"
|
|
|
+ (list :comb-decl comb opt-args args result-type)))
|
|
|
+
|
|
|
+(defun <partial-type-app-decl> ()
|
|
|
+ (choices
|
|
|
+ (named-seq?
|
|
|
+ (<- type (<boxed-type-ident>)) (sep?)
|
|
|
+ (<- ex (many1? (<subexpr> (<expr>)))) (sep?)
|
|
|
+ ";"
|
|
|
+ (list :part-type type ex))
|
|
|
+ (named-seq?
|
|
|
+ (<- type (<boxed-type-ident>)) (sep?)
|
|
|
+ "<" (<- ex (sepby1? (<expr>) ",")) ">"
|
|
|
+ (list :part-type type ex))))
|
|
|
+
|
|
|
+(defun <partial-comb-app-decl> ()
|
|
|
+ (seq-list? (<combinator-id>) (many1? (<subexpr> (<expr>)))))
|
|
|
+
|
|
|
+(defun <partial-app-decl> ()
|
|
|
+ (choices
|
|
|
+ (<partial-type-app-decl>)
|
|
|
+ (<partial-comb-app-decl>)))
|
|
|
+
|
|
|
+(defun <builtin-combinator-decl> ()
|
|
|
+ (named-seq?
|
|
|
+ (<- comb (<full-combinator-id>)) (sep?)
|
|
|
+ "?" (sep?)
|
|
|
+ "=" (sep?)
|
|
|
+ (<- type (<boxed-type-ident>)) (sep? t)
|
|
|
+ ";"
|
|
|
+ (list :builtin-decl comb type)))
|
|
|
+
|
|
|
+(defun <final-decl> ()
|
|
|
+ (named-seq?
|
|
|
+ (<- type (choices "New" "Final" "Empty"))
|
|
|
+ (whitespace?)
|
|
|
+ (<- ind (<boxed-type-ident>)) #\;
|
|
|
+ (list :final-decl type ind)))
|
|
|
+
|
|
|
+(defun <declaration> ()
|
|
|
+ (choices (<builtin-combinator-decl>)
|
|
|
+ (<combinator-decl>)
|
|
|
+ (<partial-app-decl>)
|
|
|
+ (<final-decl>)))
|
|
|
+
|
|
|
+(defun <constr-declarations> ()
|
|
|
+ (many? (named-seq? (<- dec (<declaration>)) #\; dec)))
|
|
|
+
|
|
|
+(defun <fun-declarations> ()
|
|
|
+ (many? (named-seq? (<- dec (<declaration>)) #\; dec)))
|
|
|
+
|
|
|
+(defun <tl-program> ()
|
|
|
+ (named-seq? (<- hd (<constr-declarations>))
|
|
|
+ (whitespace? :accept-empty t)
|
|
|
+ (<- tl (many?
|
|
|
+ (choice
|
|
|
+ (mdo "---" "functions" "---"
|
|
|
+ (<fun-declarations>))
|
|
|
+ (mdo "---" "types" "---"
|
|
|
+ (<constr-declarations>)))))
|
|
|
+ (cons hd tl)))
|
