From 3e43166ffc11fb117c55da594e57866a75625900 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 3 Apr 2017 23:52:19 +0200
Subject: gexp: 'lower-object' raises an exception when passed an invalid
 object.

* guix/gexp.scm (&gexp-error, &gexp-input-error): New error conditions.
(lower-object): Raise &gexp-input-error when 'lookup-compiler' returns #f.
* tests/gexp.scm ("lower-object & gexp-input-error?"): New test.
* guix/ui.scm (call-with-error-handling): Add case for 'gexp-input-error?'.
---
 guix/gexp.scm | 25 ++++++++++++++++++++++---
 1 file changed, 22 insertions(+), 3 deletions(-)

(limited to 'guix/gexp.scm')

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 1b8e43e994..80d8f735b3 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -26,6 +26,8 @@ (define-module (guix gexp)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:export (gexp
             gexp?
@@ -84,7 +86,13 @@ (define-module (guix gexp)
             gexp-compiler?
             lower-object
 
-            lower-inputs))
+            lower-inputs
+
+            &gexp-error
+            gexp-error?
+            &gexp-input-error
+            gexp-input-error?
+            gexp-error-invalid-input))
 
 ;;; Commentary:
 ;;;
@@ -140,6 +148,14 @@ (define-record-type <gexp-compiler>
   (lower      gexp-compiler-lower)
   (expand     gexp-compiler-expand))              ;#f | DRV -> sexp
 
+(define-condition-type &gexp-error &error
+  gexp-error?)
+
+(define-condition-type &gexp-input-error &gexp-error
+  gexp-input-error?
+  (input gexp-error-invalid-input))
+
+
 (define %gexp-compilers
   ;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
   (make-hash-table 20))
@@ -177,8 +193,11 @@ (define* (lower-object obj
 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>."
-  (let ((lower (lookup-compiler obj)))
-    (lower obj system target)))
+  (match (lookup-compiler obj)
+    (#f
+     (raise (condition (&gexp-input-error (input obj)))))
+    (lower
+     (lower obj system target))))
 
 (define-syntax define-gexp-compiler
   (syntax-rules (=> compiler expander)
-- 
cgit v1.2.3