#lang racket/base

(require (rename-in racket/contract (-> -->)))
(require scheme/foreign)

;;; apple-defined data types

; just the ones we actually use...
; fake the rest with _pointers
(define _os-status _sint32)
(define _item-count _ulong)
(define _byte-count _ulong)
(define _midi-ts _uint64)

; return value check
(define (check-retval where errno result)
  (if (not (= errno 0))
    (error where "Nonzero retval.")

;;; import core libraries

(define coremidi
  (ffi-lib "/System/Library/Frameworks/CoreMIDI.framework/Versions/Current/CoreMIDI"))

(define corefoundation
  (ffi-lib "/System/Library/Frameworks/CoreFoundation.framework/Versions/Current/CoreFoundation"))

;;; load coremidi functions

; utility method
; imports a coremidi function of the given name and format
(define (ffi-load name format)
  (get-ffi-obj name coremidi format
     (lambda () (error 'coremidi (string-append "Error loading " name " from CoreMIDI.")))))

(define midi-client-create
  (ffi-load "MIDIClientCreate"
            (_fun _pointer                  ; CFStringRef (client name)
                  _pointer                  ; MIDINotifyProc
                  _pointer                  ; void *
                  (ptr : (_ptr o _pointer)) ; MIDIClientRef *
                  -> (ret : _os-status)
                  -> (check-retval 'midi-client-create ret ptr))))

(define midi-client-dispose
  (ffi-load "MIDIClientDispose" (_fun _pointer ; MIDIClientRef
                                      -> (ret : _os-status)
                                      -> (check-retval 'midi-client-dispose ret ret))))

(define midi-output-port-create
  (ffi-load "MIDIOutputPortCreate"
            (_fun _pointer                  ; MIDIClientRef
                  _pointer                  ; CFString (port name)
                  (ptr : (_ptr o _pointer)) ; MIDIPortRef *
                  -> (ret : _os-status)
                  -> (check-retval 'midi-output-port-create ret ptr))))

(define midi-get-number-of-destinations
  (ffi-load "MIDIGetNumberOfDestinations" (_fun -> _item-count)))

(define midi-get-destination
  (ffi-load "MIDIGetDestination" (_fun _item-count    ; returns a
                                       -> _pointer))) ; MIDIEndPointRef *

(define midi-packet-list-init
  (ffi-load "MIDIPacketListInit" (_fun _pointer       ; returns a
                                       -> _pointer))) ; MIDIPacket *

(define midi-packet-list-add
  (ffi-load "MIDIPacketListAdd" (_fun _pointer        ; MIDIPacketList *
                                      _pointer        ; MIDIPacket *
                                      _pointer        ; const Byte *
                                      -> _pointer)))  ; MIDIPacket * (or #f)

(define midi-send
  (ffi-load "MIDISend" (_fun _pointer                 ; MIDIPortRef
                             _pointer                 ; MIDIEndpointRef
                             _pointer                 ; MIDIPacketList *
                             -> (ret : _os-status)
                             -> (check-retval 'midi-send ret ret))))

(define cf-string-create-with-cstring ; string -> CFString
  (get-ffi-obj "CFStringCreateWithCString" corefoundation (_fun _pointer _string _int -> _pointer)
     (lambda () (error 'corefoundation (string-append "Error loading CFStringCreateWithCString from CoreFoundation.")))))

;;; midi bridge proxy methods

; return the midi destination at num, or the first
; available destination if no num is given
(define (midi-destination (num 0))
  (if (< (midi-get-number-of-destinations) 1)
    (error 'midi-destination "No MIDI destinations available")
    (midi-get-destination num)))

; create a client of the given name
(define (midi-client name)
    (cf-string-create-with-cstring #f name 0) #f #f))

; open an output port of the given name for the given client
(define (midi-port client name)
      client (cf-string-create-with-cstring #f name 0)))

;;; midi connection interface

; a midi connection handle
; keeps a client, output port and midi destination
(struct midi-connection (client port destination) #:transparent)

; create a midi-connection of the given client and port names
(define (midi-open (destination 0) (client-name "name") (port-name "outport"))
  (let ((client (midi-client client-name))) 
    (midi-connection client
                     (midi-port client port-name)
                     (midi-destination destination))))

; destroy the given midi-connection handle
; really just frees the client
(define (midi-close midi)
  (midi-client-dispose (midi-connection-client midi)))

;;; midi messaging functions
;;; each take a midi-connection handle as first arg

; MIDI codes
(define ON #x90)  ; note on
(define OFF #x80) ; note off
(define AT #xA0)  ; aftertouch
(define PC #xC0)  ; program change

; pack & send args as a MIDI packet to the given midi-connection handle
(define (message midi . args)
  (define block (malloc _ubyte (length args)))
  (define packet-list (malloc 256))
  (for ((i (in-range (length args))))
    (ptr-set! block _ubyte i (list-ref args i)))
  (midi-packet-list-add packet-list 256
                        0 (length args) block)
  (midi-send (midi-connection-port midi)
             (midi-connection-destination midi)

; friendly interface methods
; send the named signal to the midi-connection handle "midi"
(define (note-on midi channel note (velocity 64))
  (message midi (bitwise-ior ON (- channel 1)) note velocity))
(define (note-off midi channel note (velocity 64))
  (message midi (bitwise-ior OFF (- channel 1)) note velocity))
(define (aftertouch midi channel note touch)
  (message midi (bitwise-ior AT (- channel 1)) note touch))
(define (program-change midi channel preset)
  (message midi (bitwise-ior PC (- channel 1)) preset))

;;; export syntax

  (midi-open (->* () (integer? string? string?) any))
  (midi-close (--> midi-connection? any))
  (note-on (->* (midi-connection? integer? integer?) (integer?) any))
  (note-off (->* (midi-connection? integer? integer?) (integer?) any))
  (aftertouch (--> midi-connection? integer? integer? integer? any))
  (program-change (--> midi-connection? integer? integer? any)))