-- | Helper functions to make it easy to start messing around

module System.MIDI.Utility
  ( selectMidiDevice
  , selectInputDevice
  , selectOutputDevice
  ) 
  where

--------------------------------------------------------------------------------

import Data.List

import Control.Monad
import Control.Concurrent

import System.IO

import System.MIDI
import System.MIDI.Base

--------------------------------------------------------------------------------

maybeRead :: Read a => String -> Maybe a
maybeRead :: String -> Maybe a
maybeRead String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of 
  [(a
x,String
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
  [(a, String)]
_        -> Maybe a
forall a. Maybe a
Nothing

-- | Utility function to help choosing a midi device.
-- If there is only a single device, we select that.
-- You can also set a default device (by its name), which
-- will be automatically selected if present.
selectMidiDevice 
  :: MIDIHasName a 
  => String         -- ^ prompt
  -> Maybe String   -- ^ default device name
  -> [a]            -- ^ list of devices
  -> IO a  
selectMidiDevice :: String -> Maybe String -> [a] -> IO a
selectMidiDevice String
prompt Maybe String
mbdefault [a]
srclist = do
  [String]
names <- (a -> IO String) -> [a] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> IO String
forall a. MIDIHasName a => a -> IO String
getName [a]
srclist
  let nsrc :: Int
nsrc = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
srclist
  String -> IO ()
putStrLn String
prompt
  a
src <- case [a]
srclist of
    []  -> do
      String -> IO ()
putStrLn String
"no midi devices found"
      String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no midi devices found"
    [a
x] -> do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"device #1 (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. [a] -> a
head [String]
names String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") selected."
      a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    [a]
_  -> do
      Int
k <- case (Maybe String -> Bool) -> [Maybe String] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
==Maybe String
mbdefault) ((String -> Maybe String) -> [String] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe String
forall a. a -> Maybe a
Just [String]
names) of
        Just Int
i -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        Maybe Int
Nothing -> do
          [(Integer, String)] -> ((Integer, String) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Integer] -> [String] -> [(Integer, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [String]
names) (((Integer, String) -> IO ()) -> IO ())
-> ((Integer, String) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Integer
i,String
name) -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
          String -> IO ()
putStr String
"please select a midi device: "
          Handle -> IO ()
hFlush Handle
stdout
          String
l <- IO String
getLine
          String -> IO ()
putStrLn String
""
          let k :: Int
k = case String -> Maybe Int
forall a. Read a => String -> Maybe a
maybeRead String
l of
                    Maybe Int
Nothing -> Int
nsrc
                    Just Int
m  -> if Int
mInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
1 Bool -> Bool -> Bool
|| Int
mInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
nsrc then Int
nsrc else Int
m
          Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
k
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"device #" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String]
names[String] -> Int -> String
forall a. [a] -> Int -> a
!!(Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") selected."
      a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ [a]
srclist[a] -> Int -> a
forall a. [a] -> Int -> a
!!(Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
src
  
-- | Select a MIDI input device (source) 
selectInputDevice :: String -> Maybe String -> IO Source  
selectInputDevice :: String -> Maybe String -> IO Source
selectInputDevice String
prompt Maybe String
mbdefault = do
  [Source]
srclist <- IO [Source]
enumerateSources
  Source
src <- String -> Maybe String -> [Source] -> IO Source
forall a. MIDIHasName a => String -> Maybe String -> [a] -> IO a
selectMidiDevice String
prompt Maybe String
mbdefault [Source]
srclist
  Source -> IO Source
forall (m :: * -> *) a. Monad m => a -> m a
return Source
src
  
-- | Select a MIDI output device (destination)
selectOutputDevice :: String -> Maybe String -> IO Destination  
selectOutputDevice :: String -> Maybe String -> IO Destination
selectOutputDevice String
prompt Maybe String
mbdefault = do
  [Destination]
dstlist <- IO [Destination]
enumerateDestinations
  Destination
dst <- String -> Maybe String -> [Destination] -> IO Destination
forall a. MIDIHasName a => String -> Maybe String -> [a] -> IO a
selectMidiDevice String
prompt Maybe String
mbdefault [Destination]
dstlist
  Destination -> IO Destination
forall (m :: * -> *) a. Monad m => a -> m a
return Destination
dst

--------------------------------------------------------------------------------