Add midiDevices to query available devices (#37)

* Add midiInputDevices and midiOutputDevice to query available devices

This change adds a new binding to the FRP.Event.MIDI module and
updates the WTK example to display the available devices list.

* Update src/FRP/Event/MIDI.purs

Co-authored-by: Mike Solomon <mike@meeshkan.com>

* Update src/FRP/Event/MIDI.purs

examples/wtk/WTK.purs

@@ -5,14 +5,15 @@ import Prelude
 import Control.Alt ((<|>))
 import Control.Comonad.Cofree (Cofree, mkCofree)
 import Control.Promise (toAffE)
+import Data.Array (fromFoldable, singleton)
 import Data.Foldable (for_)
 import Data.List (List(..))
 import Data.Maybe (Maybe(..))
 import Effect (Effect)
 import Effect.Aff.Class (class MonadAff)
 import Effect.Class (class MonadEffect)
 import FRP.Event (subscribe)
-import FRP.Event.MIDI (midi, midiAccess)
+import FRP.Event.MIDI (midi, midiAccess, midiInputDevices, MIDIDevice)
 import Halogen as H
 import Halogen.Aff (awaitBody, runHalogenAff)
 import Halogen.HTML as HH
@@ -37,6 +38,7 @@ type State
   =
   { unsubscribe :: Effect Unit
   , audioCtx :: Maybe AudioContext
+  , devices :: List MIDIDevice
   }
 
 data Action
@@ -55,11 +57,13 @@ initialState :: forall input. input -> State
 initialState _ =
   { unsubscribe: pure unit
   , audioCtx: Nothing
+  , devices: Nil
   }
 
 render :: forall m. State -> H.ComponentHTML Action () m
-render _ = do
-  HH.div_
+render s = HH.div_ (ui <> dev)
+  where
+  ui =
     [ HH.h1_
         [ HH.text "The Well-Typed Klavier" ]
     , HH.button
@@ -69,11 +73,22 @@ render _ = do
         [ HE.onClick \_ -> StopAudio ]
         [ HH.text "Stop audio" ]
     ]
+  dev = case s.devices of
+    Nil -> []
+    devices ->
+      [ HH.h4_
+          [ HH.text "Available input devices"]
+      , HH.ul_ (fromFoldable $ map (HH.li_ <<< singleton <<< HH.text <<< showDevices) devices)
+      ]
+  showDevices d =
+    let manufacturer = if d.manufacturer == "" then "" else d.manufacturer <> ": "
+     in manufacturer <> d.name
 
 handleAction :: forall output m. MonadEffect m => MonadAff m => Action -> H.HalogenM State Action () output m Unit
 handleAction = case _ of
   StartAudio -> do
     midAcc <- H.liftAff $ toAffE midiAccess
+    midDev <- H.liftEffect $ midiInputDevices midAcc
     -- alt Nil for thunk
     let
       trigger = (bufferToList 5 (midi midAcc)) <|> pure Nil
@@ -90,9 +105,9 @@ handleAction = case _ of
               (piece { makeRenderingEnv })
           )
           (\(_ :: Run Unit ()) -> pure unit)
-    H.modify_ _ { unsubscribe = unsubscribe, audioCtx = Just audioCtx }
+    H.modify_ _ { unsubscribe = unsubscribe, audioCtx = Just audioCtx, devices = midDev }
   StopAudio -> do
     { unsubscribe, audioCtx } <- H.get
     H.liftEffect unsubscribe
     for_ audioCtx (H.liftEffect <<< close)
-    H.modify_ _ { unsubscribe = pure unit, audioCtx = Nothing }
+    H.modify_ _ { unsubscribe = pure unit, audioCtx = Nothing, devices = Nil }

src/FRP/Event/MIDI.js

@@ -1,6 +1,28 @@
 exports.midiAccess = function () {
-  return navigator.requestMIDIAccess();
-};
+  return navigator.requestMIDIAccess()
+}
+
+const mkMidiDevices = function (devices) {
+  return function (mk) {
+    return function () {
+      const res = [];
+      for (let device of devices.entries()) {
+        const portID = device[0];
+        const dev = device[1];
+        res.push(mk(portID)(dev.manufacturer)(dev.name))
+      }
+      return res;
+    }
+  }
+}
+
+exports.midiInputDevices_ = function (midiAccess) {
+  return mkMidiDevices(midiAccess.inputs)
+}
+
+exports.midiOutputDevices_ = function (midiAccess) {
+  return mkMidiDevices(midiAccess.outputs)
+}
 
 exports.getData_ = function (nothing) {
   return function (just) {

src/FRP/Event/MIDI.purs

@@ -2,15 +2,19 @@ module FRP.Event.MIDI
   ( MIDIAccess(..)
   , MIDIEvent(..)
   , MIDIEventInTime(..)
+  , MIDIDevice
   , midi
   , midiAccess
+  , midiInputDevices
+  , midiOutputDevices
   ) where
 
 import Prelude
+
 import Control.Promise (Promise)
 import Data.ArrayBuffer.Types (ArrayBuffer)
 import Data.Foldable (traverse_)
-import Data.List (List)
+import Data.List (List, fromFoldable)
 import Data.Map as M
 import Data.Maybe (Maybe(..), maybe)
 import Data.Newtype (wrap)
@@ -40,6 +44,17 @@ type MIDIEventInTime
   , event :: MIDIEvent
   }
 
+-- | Represents a MIDI device.
+type MIDIDevice
+  =
+  { portID :: String
+  , manufacturer :: String
+  , name :: String
+  }
+
+mkMIDIDevice :: String -> String -> String -> MIDIDevice
+mkMIDIDevice portID manufacturer name = { portID, manufacturer, name }
+
 -- | The Web API's [MIDIAccess](https://developer.mozilla.org/en-US/docs/Web/API/MIDIAccess).
 foreign import data MIDIAccess :: Type
 
@@ -49,6 +64,16 @@ foreign import data MIDIMessageEvent :: Type
 -- | Get the [MIDIAccess](https://developer.mozilla.org/en-US/docs/Web/API/MIDIAccess) from the browser.
 foreign import midiAccess :: Effect (Promise MIDIAccess)
 
+foreign import midiInputDevices_
+  :: MIDIAccess
+  -> (String -> String -> String -> MIDIDevice)
+  -> Effect (Array MIDIDevice)
+
+foreign import midiOutputDevices_
+  :: MIDIAccess
+  -> (String -> String -> String -> MIDIDevice)
+  -> Effect (Array MIDIDevice)
+
 foreign import toTargetMap :: MIDIAccess -> Effect (O.Object EventTarget)
 
 foreign import toMIDIEvent_
@@ -90,6 +115,14 @@ toMIDIEvent =
 fromEvent :: WE.Event -> Maybe MIDIMessageEvent
 fromEvent = unsafeReadProtoTagged "MIDIMessageEvent"
 
+midiInputDevices :: MIDIAccess -> Effect (List MIDIDevice)
+midiInputDevices midiAccess_ =
+  fromFoldable <$> midiInputDevices_ midiAccess_ mkMIDIDevice
+
+midiOutputDevices :: MIDIAccess -> Effect (List MIDIDevice)
+midiOutputDevices midiAccess_ =
+  fromFoldable <$> midiOutputDevices_ midiAccess_ mkMIDIDevice
+
 -- | After having acquired the [MIDIAccess](https://developer.mozilla.org/en-US/docs/Web/API/MIDIAccess) from the browser, use it to create a streamed event of type `Event MIDIEventInTime`.
 midi :: MIDIAccess -> Event MIDIEventInTime
 midi midiAccess_ =