;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build svg)
  #:use-module (ice-9 match)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:export (svg->png))

(define (null-check! message)
  (match-lambda
    ((? null-pointer?)
     (error message))
    (pointer pointer)))

(define (int-bool-check! message)
  (match-lambda
    (0 (error message))
    (_ #t)))

(define CAIRO_STATUS_SUCCESS 0)
(define (cairo-status-check! message)
  (lambda (status)
    (or (= status CAIRO_STATUS_SUCCESS)
        (error message status))))

(define* (svg->png svg png #:key width height librsvg)
  "Build a PNG of size WIDTH and HEIGHT from SVG using LIBRSVG.
If omitted, WIDTH and HEIGHT default to the natural image size."

  (define library
    (dynamic-link (if librsvg
                      (string-append librsvg "/lib/librsvg-2.so")
                      "librsvg-2.so")))

  (define (c-function return-type name arg-types)
    (pointer->procedure return-type (dynamic-func name library) arg-types))

  (define rsvg-handle-new-from-file
    (compose (null-check! "rsvg-handle-new-from-file failed")
             (c-function '* "rsvg_handle_new_from_file" '(* *))
             (lambda (name)
               (values (string->pointer name)
                       (make-c-struct '(*) (list %null-pointer))))))

  (define rsvg-handle-get-dimensions
    (let ((get-dimensions*
           (c-function void "rsvg_handle_get_dimensions" '(* *)))
          (type (list int int double double)))
      (lambda (handle)
        (let ((dimensions (make-c-struct type '(0 0 0 0))))
          (get-dimensions* handle dimensions)
          (parse-c-struct dimensions type)))))

  (define rsvg-handle-render-cairo
    (compose (int-bool-check! "rsvg-handle-render-cairo failed")
             (c-function int "rsvg_handle_render_cairo" '(* *))))

  (define g-object-unref
    (c-function void "g_object_unref" '(*)))

  (define CAIRO_FORMAT_ARGB32 0)
  (define cairo-image-surface-create
    (compose (null-check! "cairo-image-surface-create failed")
             (c-function '* "cairo_image_surface_create"
                         (list int int int))))
  (define cairo-create (compose (null-check! "cairo-create failed")
                                (c-function '* "cairo_create" '(*))))
  (define cairo-scale (c-function void "cairo_scale" (list '* double double)))
  (define cairo-destroy (c-function void "cairo_destroy" '(*)))
  (define cairo-surface-destroy (c-function void "cairo_surface_destroy" '(*)))

  (define cairo-surface-write-to-png
    (compose (cairo-status-check! "cairo-surface-write-to-png failed")
             (c-function int "cairo_surface_write_to_png" '(* *))
             (lambda (surface name)
               (values surface (string->pointer name)))))

  (let ((rsvg-handle (rsvg-handle-new-from-file svg)))
    (match (rsvg-handle-get-dimensions rsvg-handle)
      ((natural-width natural-height . _)
       (let* ((width    (or width  natural-width))
              (height   (or height natural-height))
              (surface  (cairo-image-surface-create CAIRO_FORMAT_ARGB32
                                                    width height))
              (cr       (cairo-create surface)))
         (cairo-scale cr (/ width natural-width) (/ height natural-height))
         (rsvg-handle-render-cairo rsvg-handle cr)
         (g-object-unref rsvg-handle)
         (cairo-surface-write-to-png surface png)
         (cairo-destroy cr)
         (cairo-surface-destroy surface)
         #t)))))