;;; kolam --- GraphQL implementation
;;; Copyright © 2021, 2022 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of kolam.
;;;
;;; kolam is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; kolam 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
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with kolam.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (kolam graphql)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:export (graphql-evaluator
            graphql-schema
            define-object-type
            define-scalar-type
            define-enum-type
            non-nullable-type
            list-type
            <integer>
            <float>
            <string>
            <boolean>
            <id>
            <datetime>))

(define-record-type <schema>
  (make-schema query mutation)
  schema?
  (query schema-query)
  (mutation schema-mutation))

(define* (graphql-schema #:key query mutation)
  (make-schema query mutation))

(define-record-type <field>
  (make-field name type resolver)
  field?
  (name field-name)
  (type delayed-field-type)
  (resolver field-resolver))

(define field-type (compose force delayed-field-type))

(define-record-type <object-type>
  (make-object-type identifier fields)
  object-type?
  (identifier object-type-identifier)
  (fields object-type-fields))

(define-syntax-rule (define-object-type identifier (name type resolver) ...)
  (define identifier
    (make-object-type 'identifier
                      (list (make-field 'name (delay type) resolver) ...))))

(define-record-type <scalar-type>
  (make-scalar-type identifier predicate serializer)
  scalar-type?
  (identifier scalar-type-identifier)
  (predicate scalar-type-predicate)
  (serializer scalar-type-serializer))

(define-syntax-rule (define-scalar-type identifier predicate serializer)
  (define identifier
    (make-scalar-type 'identifier predicate serializer)))

(define-scalar-type <integer> integer? identity)
(define-scalar-type <float>
  (lambda (x)
    (and (real? x)
         (not (rational? x))))
  identity)
(define-scalar-type <string> string? identity)
(define-scalar-type <boolean> boolean? identity)
(define-scalar-type <id> string? identity)
(define-scalar-type <datetime> date? (cut date->string <> "~4"))

(define-record-type <non-nullable-type>
  (non-nullable-type subtype)
  non-nullable-type?
  (subtype non-nullable-type-subtype))

(define-record-type <list-type>
  (list-type subtype)
  list-type?
  (subtype list-type-subtype))

(define-record-type <enum-type>
  (make-enum-type enumerators)
  enum-type?
  (enumerators enum-type-enumerators))

(define-syntax-rule (define-enum-type identifier enumerators ...)
  (define identifier
    (make-enum-type (list enumerators ...))))

(define (find-field type field)
  "Find field named FIELD in TYPE."
  (find (lambda (root-type-field)
          (eq? (field-name root-type-field)
               field))
        (object-type-fields type)))

(define (correct-type? value type)
  "Return non-#f if VALUE is of GraphQL TYPE. Else, return #f."
  (cond
   ((scalar-type? type)
    (or (eq? value 'null)
        ((scalar-type-predicate type) value)))
   ((enum-type? type)
    (member value
            (cons 'null (enum-type-enumerators type))))
   ((non-nullable-type? type)
    (and (not (eq? value 'null))
         (correct-type? value (non-nullable-type-subtype type))))
   ((list-type? type)
    (or (eq? value 'null)
        (and (list? value)
             (every (cut correct-type? <> (list-type-subtype type))
                    value))))
   ((object-type? type) #t)
   (else (error "Unknown type:" type))))

(define (graphql-evaluator schema)
  (match-lambda
    (('query tree)
     (eval-graphql tree (schema-query schema)))
    (operation (error "Invalid GraphQL operation:" operation))))

(define (tree->root+alias+args+children tree)
  (let ((root children (match tree
                         ((root children ...) (values root children))
                         (leaf (values leaf #f)))))
    (match root
      (#((? symbol? root) (? symbol? alias) args ...)
       (values root alias args children))
      (#((? symbol? root) args ...)
       (values root #f args children))
      (root (values root #f '() children)))))

(define (resolvable-type? type)
  "Return non-#f if TYPE is fully resolvable, that is, it is composed
of scalar types, enum types, or lists thereof."
  (if (list-type? type)
      (resolvable-type? (list-type-subtype type))
      (or (scalar-type? type)
          (enum-type? type))))

(define* (eval-graphql tree parent-type #:optional parent)
  (let* ((root alias args children (tree->root+alias+args+children tree))
         ;; TODO: Check if required args are present.
         (root-field (or (find-field parent-type root)
                         (error "Unknown field:" root)))
         (root-type (field-type root-field))
         (underlying-type (if (non-nullable-type? root-type)
                              (non-nullable-type-subtype root-type)
                              root-type))
         (next-parent (apply (field-resolver root-field)
                             parent #f #f args)))
    (unless (correct-type? next-parent root-type)
      (error "Return value of resolver is of unexpected GraphQL type:"
             next-parent root-type))
    (when (and (not children)
               (not (resolvable-type? underlying-type)))
      (error "Leaf node must be a scalar type, an enum type, or lists thereof:"
             root-field underlying-type))
    (cons (or alias root)
          (cond
           ((eq? next-parent 'null) 'null)
           ;; List of non-object types
           ((and (list-type? underlying-type)
                 (not (object-type? (list-type-subtype underlying-type))))
            (list->vector next-parent))
           ;; List of object types
           ((list-type? underlying-type)
            (list->vector
             (map (lambda (next-parent-element)
                    (map (cut eval-graphql
                              <>
                              (list-type-subtype underlying-type)
                              next-parent-element)
                         children))
                  next-parent)))
           ;; Non-leaf node
           (children
            (map (cut eval-graphql <> underlying-type next-parent)
                 children))
           ;; Leaf node of a scalar type
           ((scalar-type? underlying-type)
            ((scalar-type-serializer underlying-type) next-parent))
           ;; Leaf node of enum type
           ((enum-type? underlying-type) next-parent)
           (else (error "eval-graphql bug: Unknown underlying-type:" underlying-type))))))