drym-org / qi / #88

Committed 14 Dec 2023 08:14PM UTC coverage: 73.205% (-21.7%) from 94.947%

Build # #88

Build Type

Pull #74

cover

Committed by

countvajhula

Commit Message

deforest: format some brackets

Pull Request Pull Request #74: Lets Write a Qi Compiler!

Run Details

947 of 1273 new or added lines in 19 files covered. (74.39%)

14 existing lines in 3 files now uncovered.

1295 of 1769 relevant lines covered (73.21%)

0.73 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

30.65

/qi-lib/flow/core/impl.rkt

#lang racket/base

(provide give
         any?
         all?
         none?
         map-values
         filter-values
         partition-values
         relay
         loom-compose
         parity-xor
         arg
         except-args
         call
         repeat-values
         foldl-values
         foldr-values
         values->list
         feedback-times
         feedback-while
         kw-helper)

(require racket/match
         (only-in racket/function
                  negate
                  thunk)
         racket/bool
         racket/list
         racket/format
         syntax/parse/define
         (for-syntax racket/base)
         racket/performance-hint)

(define-syntax-parse-rule (values->list body:expr ...+)
  (call-with-values (λ () body ...) list))

(define (kw-helper f args)
  (make-keyword-procedure
   (λ (kws kws-vs . pos)
     (keyword-apply f kws kws-vs (append args pos)))))

;; we use a lambda to capture the arguments at runtime
;; since they aren't available at compile time
(define (loom-compose f g [n #f])
  (let ([n (or n (procedure-arity f))])
    (λ args
      (let ([num-args (length args)])
        (if (< num-args n)
            (if (= 0 num-args)
                (values)
                (error 'group (~a "Can't select "
                                  n
                                  " arguments from "
                                  args)))
            (let ([sargs (take args n)]
                  [rargs (drop args n)])
              (apply values
                     (append (values->list (apply f sargs))
                             (values->list (apply g rargs))))))))))

(define (parity-xor . args) (and (foldl xor #f args) #t))

(define (counting-string n)
  (let ([d (remainder n 10)]
        [ns (number->string n)])
    (cond [(= d 1) (string-append ns "st")]
          [(= d 2) (string-append ns "nd")]
          [(= d 3) (string-append ns "rd")]
          [else (string-append ns "th")])))

(define (arg n)
  (λ args
    (cond [(> n (length args))
           (error 'select (~a "Can't select "
                              (counting-string n)
                              " value in "
                              args))]
          [(= 0 n)
           (error 'select (~a "Can't select "
                              (counting-string n)
                              " value in "
                              args
                              " -- select is 1-indexed"))]
          [else (list-ref args (sub1 n))])))

(define (except-args . indices)
  (λ args
    (let ([indices (sort indices <)])
      (if (and (not (empty? indices))
               (<= (first indices) 0))
          (error 'block (~a "Can't block "
                            (counting-string (first indices))
                            " value in "
                            args
                            " -- block is 1-indexed"))
          (let loop ([indices indices]
                     [rem-args args]
                     [cur-idx 1])
            (if (empty? indices)
                rem-args
                (match rem-args
                  ['() (error 'block (~a "Can't block "
                                         (counting-string (first indices))
                                         " value in "
                                         args))]
                  [(cons v vs)
                   (if (= cur-idx (first indices))
                       (loop (rest indices) vs (add1 cur-idx))
                       (cons v (loop indices vs (add1 cur-idx))))])))))))

;; give a (list-)lifted function available arguments
;; directly instead of wrapping them with a list
;; related to `unpack`
(define (give f)
  (λ args
    (f args)))

(define (~map f vs)
  (match vs
    ['() null]
    [(cons v vs) (append (values->list (f v))
                         (~map f vs))]))

;; Note: can probably get rid of implicit packing to args, and the
;; final apply values
(define (map-values f . args)
  (apply values (~map f args)))

(define (filter-values f . args)
  (apply values (filter f args)))

;; partition arguments by the first matching condition, then feed the
;; accumulated subsequences into associated bodies.
;; - c+bs is a list of pair?
;; - each car is a condition-flow (c) and each cdr a body-flow (b)
(define (partition-values c+bs . args)
  ;; The accumulator type is {condition-flow → [args]}. The first
  ;; accumulator, acc₀, maps conditions to empty args.
  (define acc0
    (for/hasheq ([c+b (in-list c+bs)])
      (values (car c+b) empty)))
  ;; Partition the arguments by first matching condition.
  (define by-cs
    ;; Accumulates result lists in reverse…
    (for/fold ([acc acc0]
               ;; …then reverses them.
               #:result (for/hash ([(c args) (in-hash acc)])
                          (values c (reverse args))))
      ([arg (in-list args)])
      (define matching-c
        ;; first condition…
        (for*/first ([c+b (in-list c+bs)]
                     [c (in-value (car c+b))]
                     ;; …that holds
                     #:when (c arg))
          c))
      (if matching-c
        (hash-update acc matching-c (λ (acc-at-c) (cons arg acc-at-c)))
        acc)))
  ;; Apply bodies to partitioned arguments. Each body's return values are
  ;; collected in a list, and all return-lists are collected in order of
  ;; appearance. The resulting list is flattened twice, once by apply and once
  ;; by append, to remove the lists introduced by this function. The resulting
  ;; list is the sequence of return values.
  (define results
    (for*/list ([c+b (in-list c+bs)]
                [c (in-value (car c+b))]
                [b (in-value (cdr c+b))]
                [args (in-value (hash-ref by-cs c))])
      (call-with-values (λ () (apply b args)) list)))
  (apply values (apply append results)))

(define exists ormap)

(define for-all andmap)

(define (zip-with op . seqs)
  (if (exists empty? seqs)
      (if (for-all empty? seqs)
          null
          (apply raise-arity-error
                 'relay
                 0
                 (first (filter (negate empty?) seqs))))
      (let ([vs (map first seqs)])
        (append (values->list (apply op vs))
                (apply zip-with op (map rest seqs))))))

;; from mischief/function - requiring it runs aground
;; of some "name is protected" error while building docs, not sure why;
;; so including the implementation directly here for now
(define call
  (make-keyword-procedure
   (lambda (ks vs f . xs)
     (keyword-apply f ks vs xs))))

(define (relay . fs)
  (λ args
    (apply values (zip-with call fs args))))

(define (all? . args)
  (and (for/and ([v (in-list args)]) v) #t))

(define (any? . args)
  (and (for/or ([v (in-list args)]) v) #t))

(define (none? . args)
  (not (for/or ([v (in-list args)]) v)))

(define (repeat-values n . vs)
  (apply values (apply append (make-list n vs))))

(define (fold-values f init vs)
  (let loop ([vs vs]
             [accs (values->list (init))])
    (match vs
      ['() (apply values accs)]
      [(cons v rem-vs) (loop rem-vs (values->list (apply f v accs)))])))

(define (foldl-values f init . vs)
  (fold-values f init vs))

(define (foldr-values f init . vs)
  (fold-values f init (reverse vs)))

(define (feedback-times f n then-f)
  (λ args
    (if (= n 0)
        (apply then-f args)
        (call-with-values (thunk (apply f args))
                          (feedback-times f (sub1 n) then-f)))))

(define (feedback-while f condition then-f)
  (λ args
    (let loop ([args args])
      (if (apply condition args)
          (loop (values->list
                 (apply f args)))
          (apply then-f args)))))

1	#lang racket/base	1✔
2
3	(provide give	1✔
4	any?	1✔
5	all?	1✔
6	none?	1✔
7	map-values	1✔
8	filter-values	1✔
9	partition-values	1✔
10	relay	1✔
11	loom-compose	1✔
12	parity-xor	1✔
13	arg	1✔
14	except-args	1✔
15	call	1✔
16	repeat-values	1✔
17	foldl-values	1✔
18	foldr-values	1✔
19	values->list	1✔
20	feedback-times	1✔
21	feedback-while	1✔
22	kw-helper)	1✔
23
24	(require racket/match	1✔
25	(only-in racket/function	1✔
26	negate	1✔
27	thunk)	1✔
28	racket/bool	1✔
29	racket/list	1✔
30	racket/format	1✔
31	syntax/parse/define	1✔
32	(for-syntax racket/base)	1✔
33	racket/performance-hint)	1✔
34
35	(define-syntax-parse-rule (values->list body:expr ...+)	1✔
36	(call-with-values (λ () body ...) list))	×
37
38	(define (kw-helper f args)	1✔
NEW 39	(make-keyword-procedure	×
NEW 40	(λ (kws kws-vs . pos)	×
NEW 41	(keyword-apply f kws kws-vs (append args pos)))))	×
42
43	;; we use a lambda to capture the arguments at runtime
44	;; since they aren't available at compile time
45	(define (loom-compose f g [n #f])	×
46	(let ([n (or n (procedure-arity f))])	×
47	(λ args	×
48	(let ([num-args (length args)])	×
49	(if (< num-args n)	×
50	(if (= 0 num-args)	×
51	(values)	×
52	(error 'group (~a "Can't select "	×
53	n	×
54	" arguments from "	×
55	args)))	×
56	(let ([sargs (take args n)]	×
57	[rargs (drop args n)])	×
58	(apply values	×
59	(append (values->list (apply f sargs))	×
60	(values->list (apply g rargs))))))))))	×
61
62	(define (parity-xor . args) (and (foldl xor #f args) #t))	×
63
64	(define (counting-string n)	1✔
65	(let ([d (remainder n 10)]	×
66	[ns (number->string n)])	×
67	(cond [(= d 1) (string-append ns "st")]	×
68	[(= d 2) (string-append ns "nd")]	×
69	[(= d 3) (string-append ns "rd")]	×
70	[else (string-append ns "th")])))	×
71
72	(define (arg n)	1✔
73	(λ args	×
74	(cond [(> n (length args))	×
75	(error 'select (~a "Can't select "	×
76	(counting-string n)	×
77	" value in "	×
78	args))]	×
79	[(= 0 n)	×
80	(error 'select (~a "Can't select "	×
81	(counting-string n)	×
82	" value in "	×
83	args	×
84	" -- select is 1-indexed"))]	×
85	[else (list-ref args (sub1 n))])))	×
86
87	(define (except-args . indices)	1✔
88	(λ args	×
89	(let ([indices (sort indices <)])	×
90	(if (and (not (empty? indices))	×
91	(<= (first indices) 0))	×
92	(error 'block (~a "Can't block "	×
93	(counting-string (first indices))	×
94	" value in "	×
95	args	×
96	" -- block is 1-indexed"))	×
97	(let loop ([indices indices]	×
98	[rem-args args]	×
99	[cur-idx 1])	×
100	(if (empty? indices)	×
101	rem-args	×
102	(match rem-args	×
103	['() (error 'block (~a "Can't block "	×
104	(counting-string (first indices))	×
105	" value in "	×
106	args))]	×
107	[(cons v vs)	×
108	(if (= cur-idx (first indices))	×
109	(loop (rest indices) vs (add1 cur-idx))	×
110	(cons v (loop indices vs (add1 cur-idx))))])))))))	×
111
112	;; give a (list-)lifted function available arguments
113	;; directly instead of wrapping them with a list
114	;; related to `unpack`
115	(define (give f)	1✔
116	(λ args	×
117	(f args)))	×
118
119	(define (~map f vs)	1✔
120	(match vs	×
121	['() null]	×
122	[(cons v vs) (append (values->list (f v))	×
123	(~map f vs))]))	×
124
125	;; Note: can probably get rid of implicit packing to args, and the
126	;; final apply values
127	(define (map-values f . args)	1✔
128	(apply values (~map f args)))	×
129
130	(define (filter-values f . args)	1✔
131	(apply values (filter f args)))	×
132
133	;; partition arguments by the first matching condition, then feed the
134	;; accumulated subsequences into associated bodies.
135	;; - c+bs is a list of pair?
136	;; - each car is a condition-flow (c) and each cdr a body-flow (b)
137	(define (partition-values c+bs . args)	1✔
138	;; The accumulator type is {condition-flow → [args]}. The first
139	;; accumulator, acc₀, maps conditions to empty args.
140	(define acc0	×
141	(for/hasheq ([c+b (in-list c+bs)])	×
142	(values (car c+b) empty)))	×
143	;; Partition the arguments by first matching condition.
144	(define by-cs	×
145	;; Accumulates result lists in reverse…
146	(for/fold ([acc acc0]	×
147	;; …then reverses them.
148	#:result (for/hash ([(c args) (in-hash acc)])	×
149	(values c (reverse args))))	×
150	([arg (in-list args)])	×
151	(define matching-c	×
152	;; first condition…
153	(for*/first ([c+b (in-list c+bs)]	×
154	[c (in-value (car c+b))]	×
155	;; …that holds
156	#:when (c arg))	×
157	c))	×
158	(if matching-c	×
159	(hash-update acc matching-c (λ (acc-at-c) (cons arg acc-at-c)))	×
160	acc)))	×
161	;; Apply bodies to partitioned arguments. Each body's return values are
162	;; collected in a list, and all return-lists are collected in order of
163	;; appearance. The resulting list is flattened twice, once by apply and once
164	;; by append, to remove the lists introduced by this function. The resulting
165	;; list is the sequence of return values.
166	(define results	×
167	(for*/list ([c+b (in-list c+bs)]	×
168	[c (in-value (car c+b))]	×
169	[b (in-value (cdr c+b))]	×
170	[args (in-value (hash-ref by-cs c))])	×
171	(call-with-values (λ () (apply b args)) list)))	×
172	(apply values (apply append results)))	×
173
174	(define exists ormap)	1✔
175
176	(define for-all andmap)	1✔
177
178	(define (zip-with op . seqs)	1✔
179	(if (exists empty? seqs)	×
180	(if (for-all empty? seqs)	×
181	null	×
182	(apply raise-arity-error	×
183	'relay	×
184	0	×
185	(first (filter (negate empty?) seqs))))	×
186	(let ([vs (map first seqs)])	×
187	(append (values->list (apply op vs))	×
188	(apply zip-with op (map rest seqs))))))	×
189
190	;; from mischief/function - requiring it runs aground
191	;; of some "name is protected" error while building docs, not sure why;
192	;; so including the implementation directly here for now
193	(define call	1✔
194	(make-keyword-procedure	1✔
195	(lambda (ks vs f . xs)	1✔
196	(keyword-apply f ks vs xs))))	×
197
198	(define (relay . fs)	1✔
199	(λ args	×
200	(apply values (zip-with call fs args))))	×
201
202	(define (all? . args)	1✔
203	(and (for/and ([v (in-list args)]) v) #t))	×
204
205	(define (any? . args)	1✔
206	(and (for/or ([v (in-list args)]) v) #t))	×
207
208	(define (none? . args)	1✔
209	(not (for/or ([v (in-list args)]) v)))	×
210
211	(define (repeat-values n . vs)	1✔
212	(apply values (apply append (make-list n vs))))	×
213
214	(define (fold-values f init vs)	1✔
215	(let loop ([vs vs]	×
216	[accs (values->list (init))])	×
217	(match vs	×
218	['() (apply values accs)]	×
219	[(cons v rem-vs) (loop rem-vs (values->list (apply f v accs)))])))	×
220
221	(define (foldl-values f init . vs)	1✔
222	(fold-values f init vs))	×
223
224	(define (foldr-values f init . vs)	1✔
225	(fold-values f init (reverse vs)))	×
226
227	(define (feedback-times f n then-f)	1✔
NEW 228	(λ args	×
NEW 229	(if (= n 0)	×
NEW 230	(apply then-f args)	×
NEW 231	(call-with-values (thunk (apply f args))	×
NEW 232	(feedback-times f (sub1 n) then-f)))))	×
233
234	(define (feedback-while f condition then-f)	1✔
235	(λ args	×
236	(let loop ([args args])	×
237	(if (apply condition args)	×
238	(loop (values->list	×
239	(apply f args)))	×
240	(apply then-f args)))))	×

drym-org / qi / #88

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous