generic/extract-unit.ss
(module extract-unit mzscheme
  
  (require (lib "etc.ss")
           (lib "unitsig.ss")
           (lib "list.ss" "srfi" "1")
           (lib "cut.ss" "srfi" "26")
           (lib "vector-lib.ss" "srfi" "43"))
  
  (require (planet "list.ss" ("untyped" "unlib.plt" 2))
           (planet "profile.ss" ("untyped" "unlib.plt" 2))
           (only (planet "project.ss" ("untyped" "unlib.plt" 2)) partition/mask)
           (planet "yield.ss" ("untyped" "unlib.plt" 2)))
  
  (require (file "../base.ss")
           (file "../era.ss")
           (file "../type.ss")
           (file "extract-sig.ss")
           (file "sql-sig.ss"))
  
  (provide extract@)
  
  (define extract@
    (unit/sig extract^
      (import sql-quote^)

      ;; make-struct-extracter
      ;;     : (list-of (U entity #f))
      ;;       boolean
      ;;    -> ((U (vector-of scheme-primitive) #f)
      ;;        -> (U (list-of (U persistent-struct scheme-primitive))
      ;;              persistent-struct
      ;;              scheme-primitive
      ;;              g:end)
      ;;
      ;; Creates a procedure that extracts persistent-structs from a vector of scheme primitives.
      (define (make-struct-extractor entities single-item?)
        (let ([cache (make-hash-table)])
          (if single-item?
              (lambda (source)
                (if source
                    (car (row->structs source 0 entities cache))
                    #f))
              (lambda (source)
                (if source
                    (row->structs source 0 entities cache)
                    #f)))))
      
      ;; row->structs
      ;;     : (vector-of scheme-primitive)
      ;;       integer
      ;;       (list-of (U entity #f))
      ;;       (hash-table-of entity (hash-table-of integer persistent-struct))
      ;;    -> (list-of (U persistent-struct scheme-primitive))
      ;;
      ;; Loads a list of persistent-structs, created from the data stored from
      ;; start-col to the end of row. The types of the persistent-structs are
      ;; determined by the supplied list of entities.
      ;;
      ;; Rersistent structs are cached when they are encountered for the first time
      ;; if the same record is discovered again later on in the result set, the cached
      ;; structure is re-used.
      (define (row->structs row start-col entities cache)
        (cond [(null? entities)
               null]
              [(entity? (car entities))
               (let*-values ([(entity)         (car entities)]
                             [(struct end-col) (row->struct row start-col entity cache)])
                 (cons struct (row->structs row end-col (cdr entities) cache)))]
              [else (cons (vector-ref row start-col)
                          (row->structs row
                                        (add1 start-col)
                                        (cdr entities)
                                        cache))]))
      
      ;; row->struct
      ;;     : (vector-of scheme-primitive)
      ;;       (list-of entity)
      ;;       (hash-table-of entity (hash-table-of integer persistent-struct))
      ;;    -> (values (list-of (U persistent-struct #f))
      ;;               integer)
      ;;
      ;; Loads a persistent-struct, created from the relevant amount of data stored from
      ;; start-col of row. The type of the persistent-struct is determined by the supplied
      ;; entity.
      ;;
      ;; If the struct is already in the supplied cache, the cached version is returned.
      ;; Otherwise, the struct is created from scractch and cached before it is returned.
      ;;
      ;; The procedure returns two values: the struct, and the index in row at which the
      ;; ID of the next struct can be found.
      (define (row->struct row start-col entity cache)
        (unless (< start-col (vector-length row))
          (raise-exn exn:fail:snooze
            (format "Start column index too high: ~a ~a" start-col row)))
        (let* ([id      (vector-ref row start-col)]
               [end-col (+ start-col (length (entity-fields entity)))]
               [cached  (cache-ref cache entity id)])
          (values (cond [(not id) #f]
                        [cached   cached]
                        [else     (cache-put! 
                                   cache 
                                   entity
                                   id
                                   (apply (entity-constructor entity)
                                          (s:vector->list row start-col end-col)))])
                  end-col)))
      
      ; Cache for rows->structs ------------------
      
      ;; cache-ref
      ;;     : (hash-table-of entity (hash-table-of integer persistent-struct))
      ;;       entity
      ;;       (U integer #f)
      ;;    -> (U persistent-struct #f)
      ;;
      ;; Tries to retrieve a persistent struct from the cache. Returns #f if
      ;; the struct is not cached.
      (define (cache-ref cache entity id)
        (if id
            (let ([subtable (cache-subtable cache entity)])
              (hash-table-get subtable id (lambda () #f)))
            #f))
      
      ;; cache-put!
      ;;     : (hash-table-of entity (hash-table-of integer persistent-struct))
      ;;       entity
      ;;       integer
      ;;       persistent-struct
      ;;    -> persistent-struct
      ;;
      ;; Caches and returns a (newly created) persistent struct.
      (define (cache-put! cache entity id struct)
        (define subtable 
          (cache-subtable cache entity))
        (hash-table-put! subtable id struct)
        struct)
      
      ;; cache-subtable
      ;;     : (hash-table-of entity (hash-table-of integer persistent-struct))
      ;;    -> (hash-table-of integer persistent-struct)
      ;;
      ;; Utility procedure. Used in cache-ref and cache-put!.
      (define (cache-subtable cache entity)
        (hash-table-get 
         cache
         entity
         (lambda ()
           (let ([subtable (make-hash-table)])
             (hash-table-put! cache entity subtable)
             subtable))))
      
      ))
  
  )