(declare (usual-integrations))

(define (ns->turtle pathname #!optional output-pathname)
  (let* ((p1 (pathname-default-type pathname "ns"))
	 (p2
	  (if (default-object? output-pathname)
	      (pathname-new-type p1 "ttl")
	      (pathname-default-type output-pathname "ttl"))))
    (let ((base-uri #f)
	  (triples '())
	  (original-ns-base-uri ns-base-uri)
	  (original-add-to-rdf-index add-to-rdf-index))
      (fluid-let ((ns-base-uri
		   (lambda (uri)
		     (set! base-uri uri)
		     (original-ns-base-uri uri)))
		  (add-to-rdf-index
		   (lambda (triple index)
		     (set! triples (cons triple triples))
		     (original-add-to-rdf-index triple index))))
	(ns-load p1))
      (write-turtle-file p1
			 p2
			 (or base-uri (pathname->uri p2))
			 (get-ns-prefixes)
			 (reverse! triples)))))

(define (get-ns-prefixes)
  (delete-matching-items!
      (append-map (lambda (entry)
		    (map (lambda (prefix)
			   (cons prefix (car entry)))
			 (cdr entry)))
		  %ns-prefixes)
    (lambda (p)
      (string=? (car p) ":"))))

(define (write-turtle-file p1 p2 base-uri prefixes triples)
  (call-with-output-file p2
    (lambda (output)
      (port/set-coding output 'utf-8)
      (receive (embedded groups) (get-subject-groups triples)
	(fluid-let ((*base-uri* base-uri)
		    (*base-prefix*
		     (make-uri (uri-scheme base-uri)
			       (uri-authority base-uri)
			       (uri-path base-uri)
			       (uri-query base-uri)
			       ""))
		    (*embedded-triples* embedded))
	  (write-turtle-header p1 prefixes output)
	  (write-turtle-subject-groups groups 0 output))))))

(define *base-uri*)
(define *base-prefix*)
(define *embedded-triples*)

(define (write-turtle-header pathname prefixes output)
  (write-string "# This file automatically generated at " output)
  (write-string (universal-time->local-iso8601-string (get-universal-time))
		output)
  (newline output)
  (write-string "# from " output)
  (write (->namestring pathname) output)
  (write-string "." output)
  (newline output)
  (newline output)

  (write-string "#@base " output)
  (write-uri-ref *base-uri* output)
  (write-string " ." output)
  (newline output)
  (newline output)

  (let ((prefixes
	 (sort (cons* (cons turtle-base-prefix *base-uri*)
		      (cons ":" *base-prefix*)
		      prefixes)
	   (lambda (a b)
	     (string<? (uri->string (cdr a))
		       (uri->string (cdr b)))))))
    (let ((nmax
	   (apply max
		  (map (lambda (p)
			 (string-length (car p)))
		       prefixes))))
      (for-each (lambda (prefix)
		  (write-string "@prefix " output)
		  (write-string (car prefix) output)
		  (write-chars (- nmax (string-length (car prefix)))
			       #\space
			       output)
		  (write-char #\space output)
		  (write-uri-ref (cdr prefix) output)
		  (write-string " ." output)
		  (newline output))
		prefixes)))
  (newline output))

(define turtle-base-prefix "_base_:")

(define (write-turtle-subject-groups groups depth output)
  (for-each (lambda (group)
	      (write-turtle-subject-group group depth output)
	      (newline output))
	    (sort-subject-groups groups)))

(define (sort-subject-groups groups)
  ;; should be something like topological sort, but for cyclic graphs
  groups)

(define (write-turtle-subject-group group depth output)
  (write-indentation depth output)
  (write-turtle-subject (rdf-triple-subject (car group)) depth output)
  (write-turtle-plist group #\. depth output)
  (newline output))

(define (write-turtle-plist group terminator depth output)
  (newline output)
  (let ((depth (+ depth 1)))
    (write-indentation depth output)
    (write-turtle-property (car group) depth output)
    (let loop ((group (cdr group)))
      (if (pair? group)
	  (begin
	    (write-indentation depth output)
	    (write-string "; " output)
	    (write-turtle-property (car group) depth output)
	    (loop (cdr group))))))
  (write-indentation depth output)
  (write-char terminator output))

(define (write-turtle-property triple depth output)
  (write-turtle-predicate (rdf-triple-predicate triple) depth output)
  (write-turtle-object (rdf-triple-object triple) depth output)
  (newline output))

(define (get-subject-groups triples)
  (split-list (group-triples-by-subject triples)
    (lambda (group)
      (let ((s (rdf-triple-subject (car group))))
	(and (rdf-bnode? s)
	     (= (count-matching-items triples
		  (lambda (triple)
		    (eq? (rdf-triple-object triple) s)))
		1))))))

(define (group-triples-by-subject triples)
  (let ((table (make-eq-hash-table)))
    (for-each (lambda (triple)
		(hash-table/modify! table
				    (rdf-triple-subject triple)
				    (lambda (triples) (cons triple triples))
				    '()))
	      triples)
    (map reverse! (hash-table/datum-list table))))

(define (split-list items predicate)
  (let loop ((items items) (true '()) (false '()))
    (if (pair? items)
	(if (predicate (car items))
	    (loop (cdr items)
		  (cons (car items) true)
		  false)
	    (loop (cdr items)
		  true
		  (cons (car items) false)))
	(values (reverse! true) (reverse! false)))))

(define (write-turtle-subject subject depth output)
  (cond ((uri? subject) (write-turtle-uri subject output))
	((rdf-bnode? subject) (write-bnode subject output))
	(else (error:wrong-type-argument subject "RDF subject" #f))))

(define (write-turtle-predicate predicate depth output)
  (cond ((eq? predicate rdf:type) (write-string "a" output))
	(else (write-turtle-uri predicate output))))

(define rdf:type
  (string->uri "http://www.w3.org/1999/02/22-rdf-syntax-ns#type"))

(define (write-turtle-object object depth output)
  (cond ((uri? object)
	 (write-char #\space output)
	 (write-turtle-uri object output))
	((rdf-bnode? object)
	 (let ((triples
		(find-matching-item *embedded-triples*
		  (lambda (triples)
		    (eq? (rdf-triple-subject (car triples)) object)))))
	   (if triples
	       (write-embedded-bnode triples depth output)
	       (begin
		 (write-char #\space output)
		 (write-bnode object output)))))
	((rdf-literal? object)
	 (write-char #\space output)
	 (write-literal object output))
	(else
	 (error:wrong-type-argument object "RDF object" #f))))

(define (write-embedded-bnode triples depth output)
  (write-char #\space output)
  (write-char #\[ output)
  (write-turtle-plist triples #\] depth output))

(define (write-turtle-uri uri output)
  (if (uri=? uri *base-uri*)
      (write-string turtle-base-prefix output)
      (let ((qname (ns-uri->qname uri)))
	(if (symbol? qname)
	    (write-string (symbol-name qname) output)
	    (write-uri-ref uri output)))))

(define (write-indentation depth output)
  (write-chars (* depth 4) #\space output))

(define (write-chars n char output)
  (do ((i 0 (+ i 1)))
      ((not (< i n)))
    (write-char char output)))

(for-each (let ((env (the-environment)))
	    (lambda (name)
	      (link-variables env name
			      '(runtime rdf nt) name)))
	  '(write-uri-ref
	    write-bnode
	    write-literal))

(define (ns-load pathname . rest)
  (let ((p1 (pathname-default-type pathname "ns"))
	(p2 (pathname-new-type pathname "scm")))
    (if (> (or (file-modification-time p1)
	       (error "Missing source:" p1))
	   (or (file-modification-time p2) 0))
	(preprocess-ns-file p1 p2))
    (apply load p2 rest)))

(define (preprocess-ns-file pathname #!optional output-pathname)
  (let ((pathname (merge-pathnames (pathname-default-type pathname "ns"))))
    (fluid-let ((*pp-primitives-by-name* #f)
		(*pp-uninterned-symbols-by-name* #f)
		(*pp-lists-as-tables?* #f))
      (receive (base-uri prefixes exprs)
	  (parse-ns-header (fluid-let ((*parser-canonicalize-symbols?* #f))
			     (read-file pathname))
			   pathname)
	(call-with-output-file (if (default-object? output-pathname)
				   (pathname-new-type pathname "scm")
				   output-pathname)
	  (lambda (output)
	    (generate-ns-header pathname base-uri prefixes output)
	    (for-each (lambda (expr)
			(newline output)
			(pp (rewrite-expr expr prefixes) output))
		      exprs)))))))

(define (generate-ns-header pathname base-uri prefixes output)
  (write-string ";;; This file automatically generated at " output)
  (write-string (universal-time->local-iso8601-string (get-universal-time))
		output)
  (newline output)
  (write-string ";;; from " output)
  (write (->namestring pathname) output)
  (write-string "." output)
  (newline output)
  (newline output)
  (write '(DECLARE (USUAL-INTEGRATIONS)) output)
  (newline output)
  (newline output)
  (pp `(NS-BASE-URI ,(uri->string base-uri)) output)
  (for-each (lambda (prefix)
	      (write-line `(NS-PREFIX ,(car prefix) ,(cdr prefix)) output))
	    prefixes))

(define (rewrite-expr expr prefixes)
  (let loop ((expr expr))
    (cond ((and (pair? expr)
		(symbol? (car expr))
		(pair? (cdr expr))
		(list? (cddr expr)))
	   (let ((head (rewrite-symbol (car expr) prefixes))
		 (tail (map loop (cdr expr))))
	     (if (eq? head (car expr))
		 (cons head tail)
		 `(TRIPS ,(car tail)
			 (STRING->URI
			  "http://www.w3.org/1999/02/22-rdf-syntax-ns#type")
			 ,head
			 ,@(cdr tail)))))
	  ((list? expr) (map loop expr))
	  ((symbol? expr) (rewrite-symbol expr prefixes))
	  (else expr))))

(define (rewrite-symbol sym prefixes)
  (let ((s (symbol-name sym)))
    (cond ((find-matching-item prefixes
	     (lambda (p)
	       (string-prefix? (car p) s)))
	   => (lambda (p)
		`(STRING->URI
		  ,(string-append
		    (cdr p)
		    (string-tail s (string-length (car p)))))))
	  ((->absolute-uri s #f)
	   => (lambda (uri)
		`(STRING->URI ,(uri->string uri))))
	  (else sym))))

(define (parse-ns-header exprs pathname)
  (receive (base-uri exprs) (parse-base-uri exprs pathname)
    (receive (prefixes exprs) (parse-prefixes exprs base-uri)
      (values base-uri prefixes exprs))))

(define (parse-base-uri exprs pathname)
  (if (and (pair? exprs)
	   (pair? (car exprs))
	   (eq? (caar exprs) 'NS-BASE-URI))
      (begin
	(if (not (syntax-match? '(DATUM) (cdar exprs)))
	    (error "Malformed expression:" (car exprs)))
	(values (->absolute-uri (cadar exprs))
		(cdr exprs)))
      (values (pathname->uri (pathname-new-type pathname #f))
	      exprs)))

(define (parse-prefixes exprs base-uri)
  (let loop ((exprs exprs) (prefixes '()))
    (if (and (pair? exprs)
	     (pair? (car exprs))
	     (eq? (caar exprs) 'NS-PREFIX))
	(loop (cdr exprs)
	      (cons (let ((expr (car exprs)))
		      (if (not (syntax-match? '(SYMBOL DATUM) (cdr expr)))
			  (error "Malformed expression:" expr))
		      (convert-prefix (cadr expr) (caddr expr) base-uri))
		    prefixes))
	(values (add-default-prefixes prefixes base-uri) exprs))))

(define (add-default-prefixes prefixes base-uri)
  (let loop ((defaults default-prefixes) (prefixes prefixes))
    (if (pair? defaults)
	(loop (cdr defaults)
	      (if (member (caar defaults) prefixes)
		  prefixes
		  (cons (convert-prefix (caar defaults)
					(cadar defaults)
					base-uri)
			prefixes)))
	prefixes)))

(define (convert-prefix prefix expansion base-uri)
  (cons (let ((s (symbol-name prefix)))
	  (if (not (and (string-is-xml-name? s)
			(eqv? (string-find-next-char s #\:)
			      (fix:- (string-length s) 1))))
	      (error "Malformed prefix:" prefix))
	  s)
	(uri->string (merge-uris (->uri expansion) base-uri))))

(define default-prefixes
  '((: "#")
    (rdf: "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
    (rdfs: "http://www.w3.org/2000/01/rdf-schema#")
    (xsd: "http://www.w3.org/2001/XMLSchema#")
    (owl: "http://www.w3.org/2002/07/owl#")
    (log: "http://www.w3.org/2000/10/swap/log#")
    (dc: "http://purl.org/dc/elements/1.1/")))