gexp: Compilers can now return lowerable objects.
* guix/gexp.scm (lower-object): Iterate if LOWERED is a struct. (lower+expand-object): New procedure. (gexp->sexp): Use it. (define-gexp-compiler): Adjust docstring.
This commit is contained in:
		
							parent
							
								
									a8b8ca6fd3
								
							
						
					
					
						commit
						56eafb812f
					
				
					 1 changed files with 51 additions and 23 deletions
				
			
		| 
						 | 
				
			
			@ -226,32 +226,62 @@ procedure to expand it; otherwise return #f."
 | 
			
		|||
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
 | 
			
		||||
OBJ must be an object that has an associated gexp compiler, such as a
 | 
			
		||||
<package>."
 | 
			
		||||
  (match (lookup-compiler obj)
 | 
			
		||||
    (#f
 | 
			
		||||
     (raise (condition (&gexp-input-error (input obj)))))
 | 
			
		||||
    (lower
 | 
			
		||||
     ;; Cache in STORE the result of lowering OBJ.
 | 
			
		||||
     (mlet %store-monad ((target (if (eq? target 'current)
 | 
			
		||||
                                     (current-target-system)
 | 
			
		||||
                                     (return target)))
 | 
			
		||||
                         (graft? (grafting?)))
 | 
			
		||||
       (mcached (let ((lower (lookup-compiler obj)))
 | 
			
		||||
                  (lower obj system target))
 | 
			
		||||
                obj
 | 
			
		||||
                system target graft?)))))
 | 
			
		||||
  (mlet %store-monad ((target (if (eq? target 'current)
 | 
			
		||||
                                  (current-target-system)
 | 
			
		||||
                                  (return target)))
 | 
			
		||||
                      (graft? (grafting?)))
 | 
			
		||||
    (let loop ((obj obj))
 | 
			
		||||
      (match (lookup-compiler obj)
 | 
			
		||||
        (#f
 | 
			
		||||
         (raise (condition (&gexp-input-error (input obj)))))
 | 
			
		||||
        (lower
 | 
			
		||||
         ;; Cache in STORE the result of lowering OBJ.
 | 
			
		||||
         (mcached (mlet %store-monad ((lowered (lower obj system target)))
 | 
			
		||||
                    (if (and (struct? lowered)
 | 
			
		||||
                             (not (derivation? lowered)))
 | 
			
		||||
                        (loop lowered)
 | 
			
		||||
                        (return lowered)))
 | 
			
		||||
                  obj
 | 
			
		||||
                  system target graft?))))))
 | 
			
		||||
 | 
			
		||||
(define* (lower+expand-object obj
 | 
			
		||||
                              #:optional (system (%current-system))
 | 
			
		||||
                              #:key target (output "out"))
 | 
			
		||||
  "Return as a value in %STORE-MONAD the output of object OBJ expands to for
 | 
			
		||||
SYSTEM and TARGET.  Object such as <package>, <file-append>, or <plain-file>
 | 
			
		||||
expand to file names, but it's possible to expand to a plain data type."
 | 
			
		||||
  (let loop ((obj obj)
 | 
			
		||||
             (expand (and (struct? obj) (lookup-expander obj))))
 | 
			
		||||
    (match (lookup-compiler obj)
 | 
			
		||||
      (#f
 | 
			
		||||
       (raise (condition (&gexp-input-error (input obj)))))
 | 
			
		||||
      (lower
 | 
			
		||||
       (mlet* %store-monad ((graft?  (grafting?))
 | 
			
		||||
                            (lowered (mcached (lower obj system target)
 | 
			
		||||
                                              obj
 | 
			
		||||
                                              system target graft?)))
 | 
			
		||||
         ;; LOWER might return something that needs to be further
 | 
			
		||||
         ;; lowered.
 | 
			
		||||
         (if (struct? lowered)
 | 
			
		||||
             ;; If we lack an expander, delegate to that of LOWERED.
 | 
			
		||||
             (if (not expand)
 | 
			
		||||
                 (loop lowered (lookup-expander lowered))
 | 
			
		||||
                 (return (expand obj lowered output)))
 | 
			
		||||
             (return lowered)))))))               ;self-quoting
 | 
			
		||||
 | 
			
		||||
(define-syntax define-gexp-compiler
 | 
			
		||||
  (syntax-rules (=> compiler expander)
 | 
			
		||||
    "Define NAME as a compiler for objects matching PREDICATE encountered in
 | 
			
		||||
gexps.
 | 
			
		||||
 | 
			
		||||
In the simplest form of the macro, BODY must return a derivation for PARAM, an
 | 
			
		||||
object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is
 | 
			
		||||
#f except when cross-compiling.)
 | 
			
		||||
In the simplest form of the macro, BODY must return (1) a derivation for
 | 
			
		||||
a record of the specified type, for SYSTEM and TARGET (the latter of which is
 | 
			
		||||
#f except when cross-compiling), (2) another record that can itself be
 | 
			
		||||
compiled down to a derivation, or (3) an object of a primitive data type.
 | 
			
		||||
 | 
			
		||||
The more elaborate form allows you to specify an expander:
 | 
			
		||||
 | 
			
		||||
  (define-gexp-compiler something something?
 | 
			
		||||
  (define-gexp-compiler something-compiler <something>
 | 
			
		||||
    compiler => (lambda (param system target) ...)
 | 
			
		||||
    expander => (lambda (param drv output) ...))
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -1148,12 +1178,10 @@ and in the current monad setting (system type, etc.)"
 | 
			
		|||
                  (or n? native?)))
 | 
			
		||||
               refs))
 | 
			
		||||
        (($ <gexp-input> (? struct? thing) output n?)
 | 
			
		||||
         (let ((target (if (or n? native?) #f target))
 | 
			
		||||
               (expand (lookup-expander thing)))
 | 
			
		||||
           (mlet %store-monad ((obj (lower-object thing system
 | 
			
		||||
                                                  #:target target)))
 | 
			
		||||
             ;; OBJ must be either a derivation or a store file name.
 | 
			
		||||
             (return (expand thing obj output)))))
 | 
			
		||||
         (let ((target (if (or n? native?) #f target)))
 | 
			
		||||
           (lower+expand-object thing system
 | 
			
		||||
                                #:target target
 | 
			
		||||
                                #:output output)))
 | 
			
		||||
        (($ <gexp-input> (? self-quoting? x))
 | 
			
		||||
         (return x))
 | 
			
		||||
        (($ <gexp-input> x)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Reference in a new issue