Coverage report: /home/runner/work/geb/geb/src/lambda/experimental/lambda.lisp

KindCoveredAll%
expression6986 80.2
branch24 50.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package #:geb.lambda.experimental)
2
 
3
 ;; Don't even bother to make data structures, just quote our forms
4
 
5
 (named-readtables:in-readtable :fare-quasiquote)
6
 
7
 (setf trivia:*arity-check-by-test-call* nil)
8
 
9
 ;; we are being lazy no need for defclass for something so short lived
10
 ;; IMO
11
 (eval-when (:compile-toplevel :load-toplevel :execute)
12
   (defstruct context
13
     (depth   0          :type fixnum)
14
     (mapping (fset:map) :type fset:map))
15
 
16
   (defstruct index
17
     (depth 0 :type fixnum)))
18
 
19
 `(-> a b)
20
 `void
21
 `unit
22
 `coprod
23
 `product
24
 `number
25
 
26
 (-> curry-lambda (t) t)
27
 (defun curry-lambda (term)
28
   "Takes a lambda term and expands all the arguments"
29
   (match term
30
     (`(lambda ,param ,body)
31
       (let ((body (curry-lambda body)))
32
         (mvfoldr (lambda (param body)
33
                    (list 'lambda param body))
34
                  (butlast param)
35
                  (list 'lambda (car (last param)) body))))
36
     ((cons x xs)
37
      (cons (curry-lambda x)
38
            (curry-lambda xs)))
39
     (_ term)))
40
 
41
 (-> nameless (t &optional context) t)
42
 (defun nameless (term &optional (context (make-context)))
43
   (match term
44
     (`(lambda ,param ,body)
45
       (let* ((param-ty (when (consp param) (cadr param)))
46
              (param    (if (consp param)
47
                            (car param)
48
                            param))
49
              (new-depth (1+ (context-depth context))))
50
         (list 'lambda
51
               param-ty
52
               (nameless body
53
                         (make-context
54
                          :depth new-depth
55
                          :mapping (fset:with (context-mapping context)
56
                                              param
57
                                              (- new-depth)))))))
58
     ((cons f xs)
59
      (cons (nameless f context) (nameless xs context)))
60
     ;; we only care if it's in the map, if it isn't ignore it!
61
     (_
62
      (let ((depth (fset:@ (context-mapping context) term)))
63
        (if depth
64
            (make-index :depth (+ (context-depth context) depth))
65
            term)))))