├── .travis.yml ├── LICENSE ├── README.md ├── core.lisp ├── error.lisp ├── one.asd ├── one.lisp ├── roswell └── ros-one.ros ├── tests ├── core.lisp ├── data.txt ├── one.lisp └── util.lisp └── util.lisp /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | env: 5 | global: 6 | - ROSWELL_INSTALL_DIR: $HOME/.roswell 7 | - PATH: $PATH:$HOME/.roswell/bin 8 | - COVERAGE_EXCLUDE: tests:roswell 9 | matrix: 10 | - LISP=sbcl-bin COVERALLS=true 11 | - LISP=ccl-bin 12 | - LISP=abcl 13 | # - LISP=clisp 14 | - LISP=ecl 15 | 16 | install: 17 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/release/scripts/install-for-ci.sh | sh 18 | - ros install fukamachi/rove 19 | 20 | before_script: 21 | - ros --version 22 | - ros config 23 | 24 | script: 25 | - rove one.asd 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | One - Input processing framework for Common Lisp 2 | 3 | *One* is licensed under the terms of the Lisp Lesser GNU 4 | Public License (http://opensource.franz.com/preamble.html), known as 5 | the LLGPL. The LLGPL consists of a preamble (see above URL) and the 6 | LGPL. Where these conflict, the preamble takes precedence. 7 | *One* is referenced in the preamble as the "LIBRARY." 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # One - Input processing framework 2 | 3 | [![Build Status](https://travis-ci.org/t-sin/one.svg?branch=master)](https://travis-ci.org/t-sin/one) 4 | [![Coverage Status](https://coveralls.io/repos/github/t-sin/one/badge.svg?branch=master)](https://coveralls.io/github/t-sin/one?branch=master) 5 | 6 | One provides a framework for processing input like stream, pathname and sequence. 7 | 8 | > "'Woof', huh? The japanese word 'Woof' sounds like the English word 'one'... That's it! 'Ichi' means 'one' in Japanese! So let's name him 'Ichi'! An international name. Isn't that great!" 9 | > --- Nobita, "The Kingdom of Ichi the Puppy - The Bonding", "Doraemon", Oct. 22, 2010 on air in Japan 10 | 11 | ## Installation 12 | 13 | ``` 14 | $ ros install t-sin/one 15 | ``` 16 | 17 | If you try *one* in REPL, load with quicklisp: 18 | 19 | ```lisp 20 | > (ql:quickload :one) 21 | ``` 22 | 23 | If you use *one* as one-liner, `ros one` subcommand for roswell is useful: 24 | 25 | ```sh 26 | $ ros one '(one:for ...)' 27 | ``` 28 | 29 | ### Examples 30 | 31 | - take standard input and print all lines 32 | 33 | ```sh 34 | $ seq 1 10 | ros one '(one:for - < one:read-line* $ one:print*)' 35 | 1 36 | 2 37 | 3 38 | 4 39 | 5 40 | 6 41 | 7 42 | 8 43 | 9 44 | 10 45 | ``` 46 | 47 | - take standard input and summate them 48 | 49 | ```sh 50 | $ seq 1 10 | ros one '(one:for - < one:read-line* $ parse-integer +> + 0 $ one:print)* 51 | ' 52 | 55 53 | ``` 54 | 55 | - take standard input and sort them **as string** 56 | 57 | ```sh 58 | $ seq 1 10 | shuf | ros one "(one:for - < one:read-line* > #/(sort _ #'string<) $ one:print*)" 59 | (1 10 2 3 4 5 6 7 8 9) 60 | ``` 61 | 62 | - print all lines in `access.log`, it's equivalent to `cat access.log` 63 | 64 | ```sh 65 | $ ros one '(one:for #P"access.log" < one:read-line* $ one:print*)' 66 | xxx.xxx.xxx.xx - - [dd/Jul/2017:17:59:03 +0000] "GET /index.html HTTP/1.1" 206 31140 "-" "UserAgentName" 67 | xxx.xxx.xxx.xxx - - [dd/Jul/2017:18:00:47 +0000] "GET /foo.js HTTP/1.1" 200 13944 "-" "UserAgentName" 68 | xxx.xxx.xxx.xxx - - [dd/Jul/2017:18:19:23 +0000] "GET /foo.js HTTP/1.1" 200 13944 "-" "UserAgentName" 69 | xxx.xxx.xxx.xxx - - [dd/Jul/2017:19:50:55 +0000] "GET /bar.js HTTP/1.1" 200 13944 "-" "Mozilla/5.0 ..." 70 | xxx.xxx.xxx.xxx - - [dd/Jul/2017:20:03:40 +0000] "GET /bar.js HTTP/1.1" 200 13944 "-" "Mozilla/5.0 ..." 71 | xxx.xxx.xxx.xxx - - [dd/Jul/2017:20:07:18 +0000] "GET /bazz.html HTTP/1.1" 200 13944 "-" "..." 72 | xxx.xxx.xxx.xxx - - [dd/Jul/2017:20:07:18 +0000] "GET /foo.html HTTP/1.1" 200 13944 "-" "..." 73 | ``` 74 | 75 | - print lines s.t. it satisfies regex `.*foo.*` 76 | 77 | ```sh 78 | $ ros one '(one:for #P"access.log" < one:read-line* ? #/(search "foo" _) $ one:print*)' 79 | xxx.xxx.xxx.xxx - - [dd/Jul/2017:18:00:47 +0000] "GET /foo.js HTTP/1.1" 200 13944 "-" "UserAgentName" 80 | xxx.xxx.xxx.xxx - - [dd/Jul/2017:18:19:23 +0000] "GET /foo.js HTTP/1.1" 200 13944 "-" "UserAgentName" 81 | xxx.xxx.xxx.xxx - - [dd/Jul/2017:20:07:18 +0000] "GET /foo.html HTTP/1.1" 200 13944 "-" "..." 82 | ``` 83 | 84 | - print sum of proc time for `foo.js` 85 | 86 | ```sh 87 | $ ros one '(one:for #P"access.log" < one:read-line* ? #/(search "foo.js" _) $ #/(ppcre:regex-replace ".+200 (\\d+).+" _ "\\1") $ parse-integer +> + 0 $ one:print*)' 88 | 27888 89 | ``` 90 | 91 | 92 | ## Motivation 93 | 94 | Sometime, I summarized CSV file with UNIX commands, like this: 95 | 96 | ```sh 97 | $ cat data.csv 98 | id1,1 99 | id2,2 100 | id3,3 101 | $ cat data.csv | awk -F , '{sum+=$2}END{print sum}' 102 | 9 103 | ``` 104 | 105 | But I thought: awk is complex, I want to write it with Common Lisp. Then, I do: 106 | 107 | ```sh 108 | $ cut -d ',' -f 2 data.csv | ros run -e '(print (loop for line = (read *standard-input* nil :eof) until (eq :eof line) sum line))' -q 109 | 9 110 | ``` 111 | 112 | *WTF? Maybe it's 'cause of the specters!!* 113 | 114 | However, with this library that I wrote, that crazy one-liner turns into like this: 115 | 116 | ```sh 117 | $ cut -d ',' -f 2 data.csv | ros one '(one:for* - < one:read* +> + 0)' 118 | ``` 119 | 120 | *OMG! It's shockingly NICE! 😇* 121 | 122 | *One* aimed to write shortly input processing with some features. 123 | 124 | This is the reason which to use *one*. 125 | 126 | 127 | ## Basis 128 | 129 | *One* provides three features in `one:for` macro: 130 | 131 | 1. less typing for `*standard-input*` (that is `-`) 132 | 2. loop absctraction over pathnames, streams and sequences 133 | 3. operator composition like pipe on shell or function composition 134 | 135 | ## Usage 136 | 137 | We should tell two things to *one*: **input** and **operations** applied to input. Like pipe in UNIX shell, *one* passes and process the result of left process to right, and so on. One **operation** is placed with **connective**, it denotes a behavior; composition, reduce, scan on... 138 | 139 | Generally, `one:for` should be used like this (with REGEX like notation for explain): 140 | 141 | ```lisp 142 | (one:for [ ]*) 143 | ``` 144 | 145 | ### Input 146 | 147 | `` can take **pathname**, **stream** (includes `*standard-input*`) and **sequence**. Reading and looping on stream and sequence is hidden behind `one:for` macro, but we can specify how to read from stream or sequence. For details, see *Scanning on pathname, stream or sequence*. 148 | 149 | ### Operations 150 | 151 | `` is a function that takes one argument. Basically, previous result is applied with operation then its result passed the next operation. Operations can be those: 152 | 153 | - a function 154 | - a symbol such that it is a function name (`#'` is automatically inserted) 155 | - a lambda expression 156 | 157 | For the purpose of less typing, *one* provides reader macro `#/` for lambda expression. Example is like this: 158 | 159 | ```lisp 160 | #/(string= _ "ichi") 161 | ;; -> (lambda (input) (string= input "ichi")) 162 | ``` 163 | 164 | Note that **the symbol `_` in `#/` is replaced with the argument of function 165 | 166 | ### Connectives 167 | 168 | Each *connective* denotes a behavior. There are five connectives; `$` (composition), `<` (scanning), `>` (gathering), `+>` (folding) and `?` (filtering). 169 | 170 | #### `$`: Operation Composition 171 | 172 | Composition behavior connects previoues function to next function. 173 | 174 | ```lisp 175 | (one:for ... $ ...) 176 | ``` 177 | 178 | Example: 179 | 180 | ```lisp 181 | > (one:for "ichi" $ #/(format nil "~a ni" _) $ print) 182 | "ichi ni" 183 | ``` 184 | 185 | #### `<`: Scanning on pathname, stream or sequence 186 | 187 | Scanning behavior reads for each element and applies operation on previous result, that can be pathname, stream or sequence. 188 | 189 | ```lisp 190 | (one:for ... < ...) 191 | ``` 192 | 193 | We can specify how to read element, as ``. For instance `cdr` for lists, `one:read-line*` for stream. Note that `` for streams must be return `:eof` at EOF. 194 | 195 | Example: 196 | 197 | ```lisp 198 | > (one:for '(:one :two :tree) < cdr $ print) 199 | :ONE 200 | :TWO 201 | :THREE 202 | ``` 203 | 204 | #### `>`: Gathering previous results 205 | 206 | Gathering behavior buffers all results of previous operation call and passes it as a list. 207 | 208 | ```lisp 209 | (one:for ... > ...) 210 | ``` 211 | 212 | In this case, `` translates gathering result, like sorting. Note memory usage because of gathering stores all input. 213 | 214 | Examples: 215 | 216 | ```lisp 217 | > (one:for #P"file.txt" < one:read-line* > identity $ print) 218 | ("line2" "line1" "line3") 219 | 220 | > (one:for #P"file.txt" < one:read-line* > #/(sort _ #'string<) $ print) 221 | ("line1" "line2" "line3") 222 | ``` 223 | 224 | #### `+>`: Folding previous results 225 | 226 | Folding behavior is a special case of gathering operation like `reduce`. This use memory lesser than gathering. 227 | 228 | ```lisp 229 | (one:for ... +> [] ...) 230 | ``` 231 | 232 | `` is optional. By default `` is nil. 233 | 234 | In folding, `` must take two arguments. 235 | 236 | Example: 237 | 238 | ```lisp 239 | > (one:for '("line2" "line1" "line3") < cdr 240 | +> (lambda (i v) (format nil "~a ~a" i v)) "" $ print) 241 | " line2 line1 line3" 242 | ``` 243 | 244 | #### `?`: Selection previous results 245 | 246 | Selection behavior passes previous operation results through, if the result satisfies `predicate`. 247 | 248 | ```lisp 249 | (one:for ... ? ...) 250 | ``` 251 | 252 | Example: 253 | 254 | ```lisp 255 | > (one:for '("one" "two" "three" "twenty-one") < cdr ? (search "one" _) $ print) 256 | "one" 257 | "twenty-one" 258 | ``` 259 | 260 | ## Author 261 | 262 | - Shinichi TANAKA (shinichi.tanaka45@gmail.com) 263 | 264 | ### Special thanks 265 | 266 | - Masatoshi SANO (https://gist.github.com/snmsts) 267 | - He showed me an idea as code snippet, how to process lazy, that give me lots of inspiration. 268 | - https://gist.github.com/snmsts/5abde1792c14c8a36e6c 269 | 270 | ## Copyright 271 | 272 | Copyright (c) 2017 Shinichi TANAKA (shinichi.tanaka45@gmail.com) 273 | 274 | ## License 275 | 276 | Licensed under the Lisp GNU Lesser General Public License. 277 | -------------------------------------------------------------------------------- /core.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage one/core 3 | (:use :cl) 4 | (:export :$scan 5 | :$call-if 6 | :$gather 7 | :$fold)) 8 | (in-package :one/core) 9 | 10 | 11 | (defgeneric $scan (input next-fn)) 12 | (defmethod $scan ((stream stream) (read-fn function)) 13 | "Makes scannig behavior. It reads data from `stream` with `read-fn` and calls successor operations (`op`) until :eof." 14 | (lambda (op) 15 | (loop 16 | :for e := (funcall read-fn stream) 17 | :until (eq e :eof) 18 | :do (funcall op e)))) 19 | 20 | (defmethod $scan ((sequence sequence) (step-fn function)) 21 | "Makes scanning behavior. It calls successor operations (`op`) on contents of `sequence`." 22 | (cond ((listp sequence) 23 | (lambda (op) 24 | (loop 25 | :for e :in sequence :by step-fn 26 | :do (funcall op e)))) 27 | ((vectorp sequence) 28 | (lambda (op) 29 | (loop 30 | :for e :across sequence 31 | :do (funcall op e)))))) 32 | 33 | (defun $call-if (predicate next-op) 34 | "Makes selective operation. The operation made by `$call-if` calls successor operations (`next-op`) when `predicate` returns true." 35 | (lambda (input) 36 | (when (funcall predicate input) 37 | (funcall next-op input)))) 38 | 39 | (defun $gather (gather-op) 40 | "Makes gathering operation. The operation made by `$gather` returns two functions: 41 | 42 | 1. buffering function locally named `slurp` 43 | 2. dumping function locally named `barf` 44 | 45 | 'Gathering' means it buffers values which is applied with `slurp`. `barf` dumps buffrred values as list with applying `gather-op`. `$gather` may be used to traverse list-like data, for example, sorting." 46 | (let (buffer) 47 | (flet ((slurp (input) (push input buffer)) 48 | (barf (op) 49 | (funcall op (funcall gather-op (nreverse buffer))))) 50 | (values #'slurp #'barf)))) 51 | 52 | (defun $fold (fold-op init-value) 53 | "Makes gathering operation. The operation made by `$fold` is similar to `$gather`, but `$fold` does not buffer all input. It can be used to `reduce` on list-like data." 54 | (let ((accum init-value)) 55 | (flet ((slurp (input) (setf accum (funcall fold-op accum input))) 56 | (barf (op) (funcall op accum))) 57 | (values #'slurp #'barf)))) 58 | -------------------------------------------------------------------------------- /error.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage :one/error 3 | (:use :cl) 4 | (:export :one-error 5 | :one-package-error 6 | :one-syntax-error)) 7 | (in-package :one/error) 8 | 9 | 10 | (define-condition one-error (error) 11 | ((message :initarg :message :reader message)) 12 | (:report (lambda (condition stream) 13 | (format stream "One error.~%~a~%" (message condition))))) 14 | 15 | (define-condition one-syntax-error (one-error) ()) 16 | 17 | (define-condition one-package-error (one-error) ()) 18 | -------------------------------------------------------------------------------- /one.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of one project. 3 | Copyright (c) 2017 t-sin (shinichi.tanaka45@gmail.com) 4 | |# 5 | 6 | #| 7 | Input processing framework 8 | 9 | Author: t-sin (shinichi.tanaka45@gmail.com) 10 | |# 11 | 12 | (in-package :cl-user) 13 | (defpackage one-asd 14 | (:use :cl :asdf)) 15 | (in-package :one-asd) 16 | 17 | (defsystem :one 18 | :class :package-inferred-system 19 | :description "Input processing framework" 20 | :version "0.1" 21 | :author "Shinichi TANAKA" 22 | :license "LLGPL" 23 | :depends-on ("one/one") 24 | :in-order-to ((test-op (test-op :one/tests)))) 25 | 26 | (defsystem :one/tests 27 | :class :package-inferred-system 28 | :depends-on ("rove" 29 | "one/tests/util" 30 | "one/tests/core" 31 | "one/tests/one") 32 | :perform (test-op (o c) (uiop:symbol-call :rove ':run c))) 33 | -------------------------------------------------------------------------------- /one.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage :one 3 | (:use :cl) 4 | (:import-from :one/core 5 | :$scan 6 | :$call-if 7 | :$gather 8 | :$fold) 9 | (:import-from :one/util 10 | :read* 11 | :read-char* 12 | :read-line* 13 | :print*) 14 | (:import-from :one/error 15 | :one-error 16 | :one-package-error 17 | :one-syntax-error) 18 | (:export :read* 19 | :read-char* 20 | :read-line* 21 | :read-byte* 22 | :print* 23 | 24 | :one-error 25 | :one-package-error 26 | :one-syntax-error 27 | 28 | :for 29 | :for*)) 30 | (in-package :one) 31 | 32 | 33 | (defun connective-p (e) 34 | (member e '(< > +> $ ?) 35 | :test (lambda (a b) 36 | (and (symbolp a) (string= (symbol-name a) (symbol-name b)))))) 37 | 38 | (defun replace-connective (body) 39 | (loop 40 | :for e :in body 41 | :collect (if (connective-p e) 42 | (intern (symbol-name e) :one) 43 | e))) 44 | 45 | (defun place-holder-p (e) 46 | (and (symbolp e) (string= (symbol-name e) "_"))) 47 | 48 | (defun replace-place-holder (var code) 49 | (loop 50 | :for e :in code 51 | :collect (if (place-holder-p e) 52 | var 53 | (if (listp e) 54 | (replace-place-holder var e) 55 | e)))) 56 | 57 | (defun read-operator (stream char1 char2 &optional (recursive-p t)) 58 | (declare (ignore char1 char2)) 59 | (let ((obj (read stream t nil recursive-p))) 60 | (if (atom obj) 61 | obj 62 | (if (member (car obj) '(function lambda)) 63 | obj 64 | (let ((input (gensym))) 65 | `(lambda (,input) ,(replace-place-holder input obj))))))) 66 | 67 | (set-dispatch-macro-character #\# #\/ #'read-operator) 68 | 69 | (defun parse (body &optional stree) 70 | (let ((fst (first body))) 71 | (cond ((null body) stree) 72 | ((connective-p fst) 73 | (if (eq fst '+>) 74 | (let ((connective (first body)) 75 | (fold-op (second body)) 76 | (init-value (third body))) 77 | (if (connective-p init-value) 78 | (parse (cddr body) (list connective stree fold-op)) 79 | (parse (cdddr body) (list connective stree fold-op init-value)))) 80 | (let ((connective (first body)) 81 | (next-op (second body)) 82 | (rest (cddr body))) 83 | (parse rest (list connective stree next-op))))) 84 | (t (error 'one-syntax-error :message 85 | (format nil "Parse error: ~s is not a one's connective in ~s" fst body)))))) 86 | 87 | (defun build-scan (op optree succ-op) 88 | (let ((in (gensym))) 89 | (build optree `(lambda (,in) (funcall ($scan ,in ,op) ,succ-op))))) 90 | 91 | (defun build-gather (op optree succ-op) 92 | (let ((in (gensym)) 93 | (slurp (gensym)) 94 | (barf (gensym))) 95 | `(multiple-value-bind (,slurp ,barf) 96 | ($gather ,op) 97 | (lambda (,in) 98 | (funcall ,(build optree slurp) ,in) 99 | (funcall ,barf ,succ-op))))) 100 | 101 | (defun build-fold (op initval optree succ-op) 102 | (let ((in (gensym)) 103 | (slurp (gensym)) 104 | (barf (gensym))) 105 | `(multiple-value-bind (,slurp ,barf) 106 | ($fold ,op ,initval) 107 | (lambda (,in) 108 | (funcall ,(build optree slurp) ,in) 109 | (funcall ,barf ,succ-op))))) 110 | 111 | (defun build-compose (op optree succ-op) 112 | (let ((in (gensym))) 113 | (build optree `(lambda (,in) (funcall ,succ-op (funcall ,op ,in)))))) 114 | 115 | (defun build-select (op optree succ-op) 116 | (let ((in (gensym))) 117 | (build optree `(lambda (,in) (funcall ($call-if ,op ,succ-op) ,in))))) 118 | 119 | (defun function-value (expr) 120 | (if (atom expr) 121 | `(function ,expr) 122 | expr)) 123 | 124 | (defun build (stree &optional (succ-op '#'identity)) 125 | (cond ((null stree) succ-op) 126 | ((= (length stree) 3) 127 | (destructuring-bind (connective optree op) 128 | stree 129 | (setf op (function-value op)) 130 | (ecase connective 131 | (< (build-scan op optree succ-op)) 132 | (> (build-gather op optree succ-op)) 133 | (+> (build-fold op nil optree succ-op)) 134 | ($ (build-compose op optree succ-op)) 135 | (? (build-select op optree succ-op))))) 136 | ((= (length stree) 4) 137 | (destructuring-bind (connective optree op init-value) 138 | stree 139 | (setf op (function-value op)) 140 | (ecase connective 141 | (+> (build-fold op init-value optree succ-op))))))) 142 | 143 | (defmacro for (input &body body) 144 | (cond ((and (symbolp input) (string= (symbol-name input) "-")) 145 | `(funcall ,(build (parse (replace-connective body))) *standard-input*)) 146 | ((pathnamep input) 147 | (let ((in (gensym))) 148 | `(with-open-file (,in ,input 149 | :direction :input) 150 | (funcall ,(build (parse (replace-connective body))) ,in)))) 151 | (t `(funcall ,(build (parse (replace-connective body))) ,input)))) 152 | 153 | (defmacro for* (input &body body) 154 | `(one:for ,input ,@(append body '($ one:print*)))) 155 | -------------------------------------------------------------------------------- /roswell/ros-one.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -m ros-one -L sbcl-bin -- $0 "$@" 5 | |# 6 | (progn ;;init forms 7 | (ros:ensure-asdf) 8 | #+quicklisp (ql:quickload '(:alexandria 9 | :cl-ppcre 10 | :one 11 | :serapeum 12 | :split-sequence) 13 | :silent t)) 14 | 15 | (defpackage :ros.script.ros-one.3713178048 16 | (:use :cl)) 17 | (in-package :ros.script.ros-one.3713178048) 18 | 19 | (defvar +usage+ " 20 | usage: ros one [-h] [-r SYSTEM]* [-u SYSTEM]* SEXP 21 | 22 | execute SEXP under SYSTEMS used. by default, these packages are loaded: 23 | 24 | - alexandria (use-package) 25 | - cl-ppcre (require) 26 | - one (require) 27 | - serapeum (use-package) 28 | - split-sequence (use-package) 29 | 30 | ") 31 | 32 | (defparameter default-used-systems 33 | '(:alexandria 34 | :serapeum 35 | :split-sequence)) 36 | 37 | (defstruct option help required-systems used-systems sexp) 38 | 39 | (defun parse-option (argv) 40 | (loop 41 | :for idx :from 0 :upto (1- (length argv)) 42 | :for arg := (nth idx argv) 43 | :with option := (make-option :used-systems default-used-systems) 44 | :finally (return-from parse-option option) 45 | :do (cond ((or (string= arg "-h") (string= arg "--help")) 46 | (setf (option-help option) t)) 47 | ((string= arg "-r") 48 | (progn 49 | (incf idx) 50 | (pushnew (nth idx argv) (option-required-systems option)))) 51 | ((string= arg "-u") 52 | (progn 53 | (incf idx) 54 | (pushnew (nth idx argv) (option-used-systems option)))) 55 | (t (progn 56 | (setf (option-sexp option) arg) 57 | (return-from parse-option option)))))) 58 | 59 | (defun load-systems (systems &optional (use-p nil)) 60 | (loop 61 | :for s :in systems 62 | :do (if (ql:where-is-system s) 63 | (progn 64 | (ql:quickload s :silent t) 65 | (when use-p 66 | (use-package (string-upcase s)))) 67 | (error 'one:one-package-error :message 68 | (format nil "cannot find the system: ~s~%" s))))) 69 | 70 | (defun main (&rest argv) 71 | (when (zerop (length argv)) 72 | (uiop:quit 0)) 73 | (let ((option (parse-option argv))) 74 | (when (option-help option) 75 | (format t +usage+) 76 | (uiop:quit 0)) 77 | (handler-case 78 | (progn 79 | (load-systems (option-required-systems option)) 80 | (load-systems (option-used-systems option) t) 81 | (let ((*read-eval* nil)) 82 | (eval (read-from-string (option-sexp option))))) 83 | (error (c) 84 | (format *error-output* "~a" c) 85 | (uiop:quit 1))))) 86 | 87 | 88 | ;;; vim: set ft=lisp lisp: 89 | -------------------------------------------------------------------------------- /tests/core.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage :one/tests/core 3 | (:use :cl :rove)) 4 | (in-package :one/tests/core) 5 | 6 | 7 | (defun make-test-read-fn () 8 | (let ((buffer)) 9 | (values (lambda (stream) 10 | (let ((value (read-line stream nil :eof))) 11 | (push value buffer) 12 | value)) 13 | (lambda () buffer)))) 14 | 15 | (defun make-chareq-op (s) 16 | (let ((idx 0)) 17 | (lambda (in) 18 | (diag (format nil "actually: ~s, expected: ~s~%" in (char s idx))) 19 | (ok (eq in (char s idx))) 20 | (incf idx)))) 21 | 22 | (defun make-get-op () 23 | (let ((buffer)) 24 | (values (lambda (input) (push input buffer)) 25 | (lambda () buffer)))) 26 | 27 | (deftest internal-operator-scan-test 28 | (testing "stream" 29 | (testing "function which is returned by `$scan`" 30 | (with-input-from-string (in "wan nyan") 31 | (ok (typep (one/core:$scan in #'one:read-line*) 'function)))) 32 | 33 | (testing "arity of returned function is 1" 34 | (ok (signals (with-input-from-string (in "wan nyan") 35 | (funcall (one/core:$scan in #'one:read-line*))) 36 | 'error)) 37 | (ok (null (with-input-from-string (in "wan nyan") 38 | (funcall (one/core:$scan in #'one:read-line*) 39 | #'identity)))) 40 | (ok (signals (with-input-from-string (in "wan nyan") 41 | (funcall (one/core:$scan in #'one:read-line*) 42 | #'identity 25)) 43 | 'error))) 44 | 45 | (testing "read-fn specified is used" 46 | (multiple-value-bind (read-fn get-fn) 47 | (make-test-read-fn) 48 | (with-input-from-string (in "nobita-san") 49 | (funcall (one/core:$scan in read-fn) #'identity)) 50 | (ok (equal (funcall get-fn) '(:eof "nobita-san"))))) 51 | 52 | (testing "read-fn must be returns :eof when stream end, or signals error" 53 | (with-input-from-string (in "nobita-san") 54 | (ok (null (funcall (one/core:$scan in (lambda (stream) (read-char stream nil :eof))) 55 | #'identity)))) 56 | (with-input-from-string (in "nobita-san") 57 | (ok (signals (funcall (one/core:$scan in #'read-char) #'identity) 58 | 'error)))) 59 | 60 | (testing "op is called for all stream elements") 61 | (let ((s "hachi")) 62 | (with-input-from-string (in s) 63 | (funcall (one/core:$scan in #'one:read-char*) 64 | (make-chareq-op s))))) 65 | 66 | (testing "sequence" 67 | (testing "function which is returned by `$scan`" 68 | (ok (typep (one/core:$scan '(1 2 3 4) #'cdr) 'function))) 69 | 70 | (testing "arity of returned function is 1" 71 | (ok (signals (funcall (one/core:$scan '(1 2 3 4) #'cdr)) 'error)) 72 | (ok (null (funcall (one/core:$scan '(1 2 3 4) #'cdr) #'identity))) 73 | (ok (signals (funcall (one/core:$scan '(1 2 3 4) #'cdr) 74 | #'identity 25) 75 | 'error))) 76 | 77 | (testing "next-fn specified is used" 78 | (multiple-value-bind (op get-fn) 79 | (make-get-op) 80 | (funcall (one/core:$scan '(1 2 3 4) #'cddr) op) 81 | (ok (equal (funcall get-fn) '(3 1))))) 82 | 83 | (testing "op is called for all stream elements" 84 | (let ((s "ichi")) 85 | (funcall (one/core:$scan s #'identity) (make-chareq-op s)))))) 86 | 87 | 88 | (defun make-call-if-test-op () 89 | (let ((called nil)) 90 | (values (lambda (input) (setf called input)) 91 | (lambda () called)))) 92 | 93 | (deftest internal-operator-call-if-test 94 | (testing "function is returned when `$call-if` is called" 95 | (ok (typep (one/core:$call-if #'identity #'identity) 'function))) 96 | 97 | (testing "arity of returned function is 1, that is input" 98 | (ok (signals (funcall (one/core:$call-if #'identity #'identity)) 99 | 'error)) 100 | (diag "`$call-if` returns evaluated value, but don't care") 101 | (ok (funcall (one/core:$call-if #'identity #'identity) "ichi")) 102 | (ok (signals (funcall (one/core:$call-if #'identity #'identity) "ichi" "hachi") 103 | 'error))) 104 | 105 | (testing "called successor operation when input is true by predicate" 106 | (multiple-value-bind (op get-fn) 107 | (make-call-if-test-op) 108 | (funcall (one/core:$call-if #'zerop op) 0) 109 | (ok (eq (funcall get-fn) 0))) 110 | (multiple-value-bind (op get-fn) 111 | (make-call-if-test-op) 112 | (funcall (one/core:$call-if #'zerop op) 1) 113 | (ok (null (funcall get-fn)))))) 114 | 115 | (deftest internal-operator-gather-test 116 | (testing "`$gather` returns two functions" 117 | (ok (eq (length (multiple-value-list (one/core:$gather #'identity))) 2)) 118 | (multiple-value-bind (slurp barf) 119 | (one/core:$gather #'identity) 120 | (ok (typep slurp 'function)) 121 | (ok (typep barf 'function)))) 122 | 123 | (testing "arity of 'slurp' is 1, input from previous operation" 124 | (multiple-value-bind (slurp barf) 125 | (one/core:$gather #'identity) 126 | (declare (ignore barf)) 127 | (ok (signals (funcall slurp) 'error)) 128 | (ok (funcall slurp 1)) 129 | (ok (signals (funcall slurp 1 2) 'error)))) 130 | 131 | (testing "arity of 'barf' is 1, successor operation" 132 | (multiple-value-bind (slurp barf) 133 | (one/core:$gather #'identity) 134 | (funcall slurp 1) 135 | (ok (signals (funcall barf) 'error)) 136 | (ok (funcall barf #'identity)) 137 | (ok (signals (funcall barf #'identity 2) 'error)))) 138 | 139 | (testing "gathering operation do something like reduce" 140 | (testing "gathering operation pass through gathered inputs" 141 | (multiple-value-bind (slurp barf) 142 | (one/core:$gather #'identity) 143 | (funcall slurp "nobita") 144 | (funcall slurp "doraemon") 145 | (funcall slurp "shizuka") 146 | (funcall slurp "takeshi") 147 | (funcall slurp "suneo") 148 | (ok (equal (funcall barf #'identity) '("nobita" "doraemon" "shizuka" "takeshi" "suneo"))))) 149 | (testing "gathering with sorting" 150 | (multiple-value-bind (slurp barf) 151 | (one/core:$gather (lambda (lis) (sort lis #'string<))) 152 | (funcall slurp "nobita") 153 | (funcall slurp "doraemon") 154 | (funcall slurp "shizuka") 155 | (funcall slurp "takeshi") 156 | (funcall slurp "suneo") 157 | (ok (equal (funcall barf #'identity) 158 | '("doraemon" "nobita" "shizuka" "suneo" "takeshi"))))) 159 | (testing "gathering with concatenation" 160 | (multiple-value-bind (slurp barf) 161 | (one/core:$gather (lambda (lis) (format nil "~{~a~^-~}" lis))) 162 | (funcall slurp "nobita") 163 | (funcall slurp "doraemon") 164 | (funcall slurp "shizuka") 165 | (funcall slurp "takeshi") 166 | (funcall slurp "suneo") 167 | (ok (string= (funcall barf #'identity) 168 | "nobita-doraemon-shizuka-takeshi-suneo"))))) 169 | 170 | (testing "when calling 'barf', successor operation is applied to buffered input" 171 | (testing "identity" 172 | (multiple-value-bind (slurp barf) 173 | (one/core:$gather #'identity) 174 | (funcall slurp "nobita") 175 | (funcall slurp "doraemon") 176 | (funcall slurp "shizuka") 177 | (funcall slurp "takeshi") 178 | (funcall slurp "suneo") 179 | (ok (equal (funcall barf #'identity) 180 | '("nobita" "doraemon" "shizuka" "takeshi" "suneo"))))) 181 | (testing "sorting after gathering; do same above" 182 | (multiple-value-bind (slurp barf) 183 | (one/core:$gather #'identity) 184 | (funcall slurp "nobita") 185 | (funcall slurp "doraemon") 186 | (funcall slurp "shizuka") 187 | (funcall slurp "takeshi") 188 | (funcall slurp "suneo") 189 | (ok (equal (funcall barf (lambda (lis) (sort lis #'string<))) 190 | '("doraemon" "nobita" "shizuka" "suneo" "takeshi"))))) 191 | (testing "concatenation after gathering; do same above" 192 | (multiple-value-bind (slurp barf) 193 | (one/core:$gather #'identity) 194 | (funcall slurp "nobita") 195 | (funcall slurp "doraemon") 196 | (funcall slurp "shizuka") 197 | (funcall slurp "takeshi") 198 | (funcall slurp "suneo") 199 | (ok (string= (funcall barf (lambda (lis) (format nil "~{~a~^-~}" lis))) 200 | "nobita-doraemon-shizuka-takeshi-suneo")))))) 201 | 202 | (deftest internal-operator-fold-test 203 | (testing "`$fold` returns two functions" 204 | (multiple-value-bind (slurp barf) 205 | (one/core:$fold (lambda (x y) (declare (ignore x)) y) nil) 206 | (ok (typep slurp 'function)) 207 | (ok (typep barf 'function)))) 208 | 209 | (testing "arity of 'slurp' is 1, input from previous operation" 210 | (multiple-value-bind (slurp barf) 211 | (one/core:$fold (lambda (x y) (declare (ignore x)) y) nil) 212 | (declare (ignore barf)) 213 | (ok (signals (funcall slurp) 'error)) 214 | (ok (funcall slurp 1)) 215 | (ok (signals (funcall slurp 2 1) 'error)))) 216 | 217 | (testing "arity of 'barf' is 1, successor operation" 218 | (multiple-value-bind (slurp barf) 219 | (one/core:$fold (lambda (x y) (declare (ignore x)) y) nil) 220 | (funcall slurp 1) 221 | (ok (signals (funcall barf) 'error)) 222 | (ok (funcall barf #'identity)) 223 | (ok (signals (funcall barf #'identity 2) 'error)))) 224 | 225 | (testing "folding operation do something like reduce" 226 | (testing "fold-op takes two parameter: accumrator initialized init-value and input" 227 | (ok (signals (funcall (one/core:$fold (lambda (x) x) nil) 0) 'error)) 228 | (ok (signals (funcall (one/core:$fold (lambda (x y) (declare (ignore x)) y) nil)))) 229 | (ok (signals (funcall (one/core:$fold (lambda (x y z) (declare (ignore x y)) z) nil) 'error)))) 230 | 231 | (testing "folding operation pass initial value through in folding process" 232 | (multiple-value-bind (slurp barf) 233 | (one/core:$fold (lambda (x y) (declare (ignore y)) x) "ichi") 234 | (funcall slurp "hachi") 235 | (funcall slurp "chiko") 236 | (funcall slurp "bulltaro") 237 | (funcall slurp "daku") 238 | (ok (equal (funcall barf #'identity) "ichi"))) 239 | 240 | (testing "folding operation with concatenation" 241 | (multiple-value-bind (slurp barf) 242 | (one/core:$fold (lambda (x y) (format nil "~a-~a" x y)) "") 243 | (funcall slurp "hachi") 244 | (funcall slurp "chiko") 245 | (funcall slurp "bulltaro") 246 | (funcall slurp "daku") 247 | (ok (equal (funcall barf #'identity) "-hachi-chiko-bulltaro-daku")))))) 248 | 249 | (testing "successor operation is called" 250 | (multiple-value-bind (slurp barf) 251 | (one/core:$fold (lambda (x y) (declare (ignore x)) y) nil) 252 | (funcall slurp "hachi") 253 | (ok (equal (funcall barf (lambda (x) (format nil "~a!!!!" x))) "hachi!!!!"))))) 254 | -------------------------------------------------------------------------------- /tests/data.txt: -------------------------------------------------------------------------------- 1 | wan 2 | nyan 3 | -------------------------------------------------------------------------------- /tests/one.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage :one/tests/one 3 | (:use :cl :rove)) 4 | (in-package :one/tests/one) 5 | 6 | 7 | (deftest internal-util-test 8 | (testing "checks if supplied symbol is one's connective?" 9 | (testing "one's connectives are fives bellow" 10 | (ok (one::connective-p '<)) ; scan 11 | (ok (one::connective-p '>)) ; gather 12 | (ok (one::connective-p '+>)) ; fold 13 | (ok (one::connective-p '$)) ; compose 14 | (ok (one::connective-p '?))) ; call-if 15 | 16 | (testing "there's no connectives" 17 | (ng (one::connective-p '->)) 18 | (ng (one::connective-p '|\||)))) 19 | 20 | (testing "replace connectives in toplevel code" 21 | (ok (null (one::replace-connective nil))) 22 | 23 | (ok (equal (one::replace-connective '(< > +> $ ?)) 24 | '(< > one::+> one::$ one::?))) 25 | 26 | (testing "replacement occurs only toplevel elements" 27 | (ok (equal (one::replace-connective '((< > +> $ ?))) 28 | '((< > +> $ ?)))))) 29 | 30 | (testing "replacement placeholders" 31 | (testing "'place holder' is a symbol named `_`." 32 | (ok (one::place-holder-p 'one::_)) 33 | (ok (one::place-holder-p 'one/core::_))) 34 | 35 | (testing "replace all `_` in given S-expression" 36 | (ok (equal (one::replace-place-holder '-replaced- 37 | '(lambda (in) (cons in (cons _)))) 38 | '(lambda (in) (cons in (cons -replaced-))))) 39 | (ok (equal (one::replace-place-holder '-replaced- 40 | '(lambda () (+ _ _))) 41 | '(lambda () (+ -replaced- -replaced-))))))) 42 | 43 | (deftest one-operator-reader 44 | (testing "reading atom; passing through" 45 | (with-input-from-string (in "nil") 46 | (ok (rove/core/assertion::equal* 47 | (one::read-operator in #\# #\/ nil) 48 | nil))) 49 | (with-input-from-string (in "42") 50 | (ok (rove/core/assertion::equal* 51 | (one::read-operator in #\# #\/ nil) 52 | 42)))) 53 | 54 | (testing "reading list" 55 | (testing "special treatment for lambda" 56 | (with-input-from-string (in "(lambda a b)") 57 | (ok (rove/core/assertion::equal* 58 | (one::read-operator in #\# #\/ nil) 59 | '(lambda a b)))) 60 | (with-input-from-string (in "(lambda a _)") 61 | (ok (rove/core/assertion::equal* 62 | (one::read-operator in #\# #\/ nil) 63 | '(lambda a _))))) 64 | 65 | (with-input-from-string (in "(a b c)") 66 | (ok (rove/core/assertion::equal* 67 | (one::read-operator in #\# #\/ nil) 68 | '(lambda (#:gensym) (a b c))))) 69 | 70 | (testing "replace `_`" 71 | (with-input-from-string (in "(a _ c)") 72 | (ok (rove/core/assertion::equal* 73 | (one::read-operator in #\# #\/ nil) 74 | '(lambda (#:gensym) (a #:gensym c)))))))) 75 | 76 | (deftest one-parse-test 77 | (testing "empty body, returns stree" 78 | (ok (eq (one::parse '() nil) nil)) 79 | (ok (eq (one::parse '() 'stree) 'stree))) 80 | 81 | (testing "basic syntax is: [conn op-fn]*" 82 | (ok (equal (one::parse '(one::$ fn1)) 83 | '(one::$ nil fn1))) 84 | (ok (equal (one::parse '(one::$ fn1 one::> fn2)) 85 | '(one::> (one::$ nil fn1) fn2))) 86 | (ok (equal (one::parse '(one::$ fn1 one::> fn2 one::? fn3)) 87 | '(one::? (one::> (one::$ nil fn1) fn2) fn3)))) 88 | 89 | (testing "special treatment for folding behavior `+>`" 90 | (ok (equal (one::parse '(one::$ fn1 one::+> fn2 one::? fn3)) 91 | '(one::? (one::+> (one::$ nil fn1) fn2) fn3)) 92 | "1. folding behavior with one parameter: folding operation") 93 | (ok (equal (one::parse '(one::$ fn1 one::+> fn2 :init one::? fn3)) 94 | '(one::? (one::+> (one::$ nil fn1) fn2 :init) fn3)) 95 | "2. folding behavior with two parameters: folding operation and initial value")) 96 | 97 | (testing "syntax errors" 98 | (ok (signals (one::parse '(-> fn1)) 'one/error:one-syntax-error) 99 | "error occurs: first element is not a connective") 100 | (ok (signals (one::parse '(fn1 fn2)) 'one/error:one-syntax-error) 101 | "error occurs: first element is not a connective")) 102 | 103 | (testing "some abnormal case" 104 | (ok (equal (one::parse '(one::$)) '(one::$ nil nil)) 105 | "parse OK, empty syntax tree is returned. this maybe raise error on `build`"))) 106 | 107 | (deftest one-build-utility-test 108 | (testing "scan: `<`" 109 | (ok (rove/core/assertion::equal* 110 | (one::build '(one::< nil read-line)) 111 | '(lambda (#:in) (funcall (one/core:$scan #:in #'read-line) #'identity))))) 112 | 113 | (testing "gather: `>`" 114 | (ok (rove/core/assertion::equal* 115 | (one::build '(one::> nil (lambda (x) (sort x #'<)))) 116 | '(multiple-value-bind (#:slurp #:barf) 117 | (one/core:$gather (lambda (x) (sort x #'<))) 118 | (lambda (#:in) 119 | (funcall #:slurp #:in) 120 | (funcall #:barf #'identity)))))) 121 | 122 | (testing "fold: `+>`" 123 | (ok (rove/core/assertion::equal* 124 | (one::build '(one::+> nil +)) 125 | '(multiple-value-bind (#:slurp #:barf) 126 | (one/core:$fold #'+ nil) 127 | (lambda (#:in) 128 | (funcall #:slurp #:in) 129 | (funcall #:barf #'identity))))) 130 | (ok (rove/core/assertion::equal* 131 | (one::build '(one::+> nil + 1)) 132 | '(multiple-value-bind (#:slurp #:barf) 133 | (one/core:$fold #'+ 1) 134 | (lambda (#:in) 135 | (funcall #:slurp #:in) 136 | (funcall #:barf #'identity)))))) 137 | 138 | (testing "compose: `$`" 139 | (ok (rove/core/assertion::equal* 140 | (one::build '(one::$ nil print)) 141 | '(lambda (#:in) (funcall #'identity (funcall #'print #:in)))))) 142 | 143 | (testing "call-if: `?`" 144 | (ok (rove/core/assertion::equal* 145 | (one::build '(one::? nil oddp)) 146 | '(lambda (#:in) (funcall (one/core:$call-if #'oddp #'identity) #:in)))))) 147 | 148 | (deftest function-value-test 149 | (testing "for atom, wrap with `(function)`" 150 | (ok (equal (one::function-value 'string=) 151 | '#'string=))) 152 | 153 | (testing "otherwise, just return it" 154 | (ok (one::function-value '(format nil " ~a" _)) 155 | '(format nil " ~a")))) 156 | 157 | (deftest one-build-test 158 | (diag "to be written...")) 159 | 160 | (deftest one-for-test 161 | (testing "normal case" 162 | (ok (expands '(one:for *standard-input* < one:read-line* $ print) 163 | '(funcall (lambda (#:in2) 164 | (funcall (one/core:$scan #:in2 #'one:read-line*) 165 | (lambda (#:in) 166 | (funcall #'identity (funcall #'print #:in))))) 167 | *standard-input*)))) 168 | (testing "for pathname" 169 | (ok (expands '(one:for #P"one.asd" < one:read-line* $ print) 170 | '(with-open-file (#:instream #P"one.asd" :direction :input) 171 | (funcall (lambda (#:in2) 172 | (funcall (one/core:$scan #:in2 #'one:read-line*) 173 | (lambda (#:in) 174 | (funcall #'identity (funcall #'print #:in))))) 175 | #:instream))))) 176 | (testing "shorthand for standard input" 177 | (ok (expands '(one:for - < one:read-line* $ print) 178 | '(funcall (lambda (#:in2) 179 | (funcall (one/core:$scan #:in2 #'one:read-line*) 180 | (lambda (#:in) 181 | (funcall #'identity (funcall #'print #:in))))) 182 | *standard-input*))))) 183 | 184 | (deftest one-for*-test 185 | (testing "shorthand for stdout" 186 | (ok (expands '(one:for* - < one:read-line*) 187 | '(one:for - < one/util:read-line* one::$ one/util:print*))))) 188 | -------------------------------------------------------------------------------- /tests/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage :one/tests/util 3 | (:use :cl :rove)) 4 | (in-package :one/tests/util) 5 | 6 | (deftest util-read*-test 7 | (with-input-from-string (in "wannyan spacetime odessey") 8 | (ok (equal (one/util:read* in) 'wannyan)) 9 | (ok (equal (one/util:read* in) 'spacetime)) 10 | (ok (equal (one/util:read* in) 'odessey)) 11 | (ok (equal (one/util:read* in) :eof)))) 12 | 13 | (deftest util-read-char*-test 14 | (with-input-from-string (in "ichi") 15 | (ok (equal (one/util:read-char* in) #\i)) 16 | (ok (equal (one/util:read-char* in) #\c)) 17 | (ok (equal (one/util:read-char* in) #\h)) 18 | (ok (equal (one/util:read-char* in) #\i)) 19 | (ok (equal (one/util:read-char* in) :eof)))) 20 | 21 | (deftest util-read-line*-test 22 | (with-input-from-string (in (format nil "doraemon~%the~%movie")) 23 | (ok (equal (one/util:read-line* in) "doraemon")) 24 | (ok (equal (one/util:read-line* in) "the")) 25 | (ok (equal (one/util:read-line* in) "movie")) 26 | (ok (equal (one/util:read-line* in) :eof)))) 27 | 28 | (deftest util-print*-test 29 | (with-output-to-string (out) 30 | (let ((*standard-output* out)) 31 | (one/util:print* 42)) 32 | (ok (equal (get-output-stream-string out) "42 33 | ")))) 34 | -------------------------------------------------------------------------------- /util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage :one/util 3 | (:use :cl) 4 | (:export :read* 5 | :read-char* 6 | :read-line* 7 | :print*)) 8 | (in-package :one/util) 9 | 10 | 11 | (defun read* (stream) 12 | (read stream nil :eof)) 13 | 14 | (defun read-char* (stream) 15 | (read-char stream nil :eof)) 16 | 17 | (defun read-line* (stream) 18 | (read-line stream nil :eof)) 19 | 20 | (defun print* (input) 21 | (format t "~a~%" input)) 22 | --------------------------------------------------------------------------------