(defpackage :trivia.cffi
  (:import-from :cffi :null-pointer)
  (:export :-> :null-pointer))

(defpackage :trivia.cffi.impl
  (:use :cl :alexandria :cffi
        :trivia.level0
        :trivia.level1
        :trivia.level2
        :trivia.cffi))

(in-package :trivia.cffi.impl)

(defpattern -> (foreign-type &rest slots)
  "Accesses slot values in a foreign object pointer.

(defcstruct bar
  (baz :int))
(defcstruct foo         ; or (defcstruct foo
  (bar (:struct bar)))  ;      (bar (:pointer (:struct bar))))
                        ; or struct foo { bar *bar; }

(match (foreign-alloc 'foo) ; returns a pointer
  ((-> (:struct foo)
       bar)                           ; foreign-slot-value access (leaf pattern)
   bar))

-> a list (BAZ -121372672) returned by cffi:foreign-slot-value.
the list is generated by a generic function cffi:translate-from-foreign specialized on (T CFFI::FOREIGN-STRUCT-TYPE).


(match (foreign-alloc 'foo) ; returns a pointer
  ((-> (:struct foo)
       (& bar))                       ; explicit foreign-slot-pointer access
   bar))

-> #.(SB-SYS:INT-SAP #X7F8C40000DE0) , a foreign pointer.


(match (foreign-alloc 'foo) ; returns a pointer
  ((-> (:struct foo)
       (bar myval))                       ; implicit foreign-slot-pointer access (nested pattern).
   myval))

-> #.(SB-SYS:INT-SAP #X7F8C40000E00) , a foreign pointer.


(match (foreign-alloc 'foo) ; returns a pointer
  ((-> (:struct foo)
       (bar                           ; implicit foreign-slot-pointer access (nested pattern)
        ;; the result is further matched against struct bar
        (-> (:struct bar)
            baz)))                      ; leaf node: value access
   baz))

-> 0 , an uninitialized integer.
"
  (with-gensyms (obj)
    `(guard1 (,obj :type foreign-pointer)
             (typep ,obj 'foreign-pointer)
             ,@(mappend
                (lambda (slot)
                  (ematch slot
                    ((symbol)
                     `((foreign-slot-value ,obj ',foreign-type ',slot) ,slot))
                    ((list (symbol :name "&") slot-name)
                     `((foreign-slot-pointer ,obj ',foreign-type ',slot-name) ,slot-name))
                    ((list slot-name subpattern)
                     `((foreign-slot-pointer ,obj ',foreign-type ',slot-name) ,subpattern))))
                slots))))

(defpattern null-pointer ()
  "Matches when the given foreign pointer is null. "
  (with-gensyms (obj)
    `(guard1 (,obj :type foreign-pointer)
             (null-pointer-p ,obj))))


