Option.hs

module Synthesizer.LLVM.Server.Option (
   T(..),
   get,
   defaultChannel,
   Play.defaultChunkSize,
   defaultSampleRate,
   defaultLatency,
   SampleRate(SampleRate),
   ) where

import Synthesizer.LLVM.Server.Common (SampleRate(SampleRate), )
import qualified Synthesizer.ALSA.Storable.Play as Play
import qualified Data.StorableVector.Lazy       as SVL
import Synthesizer.ALSA.EventList (ClientName(ClientName))

import qualified Sound.MIDI.Message.Channel as ChannelMsg

import System.Console.GetOpt
          (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )
import System.Environment (getArgs, getProgName, )
import System.Exit (exitSuccess, exitFailure, )
import qualified System.IO as IO

import Control.Monad (when, )

import Prelude hiding (Real, )


data T =
   Cons {
      device :: Play.Device,
      clientName :: ClientName,
      channel, extraChannel :: ChannelMsg.Channel,
      sampleDirectory :: FilePath,
      sampleRate :: Maybe (SampleRate Int),
      chunkSize :: SVL.ChunkSize,
      latency :: Int
   }
   deriving (Show)


deflt :: T
deflt =
   Cons {
      device = Play.defaultDevice,
      clientName = defaultClientName,
      channel = defaultChannel,
      extraChannel = ChannelMsg.toChannel 1,
      sampleDirectory = "speech",
      sampleRate = Nothing,
      chunkSize = Play.defaultChunkSize,
      latency = defaultLatency
   }

defaultClientName :: ClientName
defaultClientName =
   ClientName "Haskell-LLVM-Synthesizer"

defaultChannel :: ChannelMsg.Channel
defaultChannel = ChannelMsg.toChannel 0

defaultSampleRate :: Num a => a
-- defaultSampleRate = 24000
-- defaultSampleRate = 48000
defaultSampleRate = 44100

defaultLatency :: Int
defaultLatency =
   -- 0
   -- 256
   1024



exitFailureMsg :: String -> IO a
exitFailureMsg msg =
   IO.hPutStrLn IO.stderr msg >> exitFailure

parseChannel :: String -> IO ChannelMsg.Channel
parseChannel str =
   case reads str of
      [(chan, "")] ->
         if 0<=chan && chan<16
           then return $ ChannelMsg.toChannel chan
           else exitFailureMsg "MIDI channel must a number from 0..15"
      _ ->
         exitFailureMsg $ "channel must be a number, but is '" ++ str ++ "'"

parseNumber ::
   (Read a) =>
   String -> (a -> Bool) -> String -> String -> IO a
parseNumber name constraint constraintName str =
   case reads str of
      [(n, "")] ->
         if constraint n
           then return n
           else exitFailureMsg $ name ++ " must be a " ++ constraintName ++ " number"
      _ ->
         exitFailureMsg $ name ++ " must be a number, but is '" ++ str ++ "'"

maxInt :: Integer
maxInt =
   fromIntegral (maxBound :: Int)


{-
Guide for common Linux/Unix command-line options:
  http://www.faqs.org/docs/artu/ch10s05.html
-}
description :: [OptDescr (T -> IO T)]
description =
   Option ['h'] ["help"]
      (NoArg $ \ _flags -> do
         programName <- getProgName
         putStrLn
            (usageInfo ("Usage: " ++ programName ++ " [OPTIONS]") description)
         exitSuccess)
      "show options" :
   Option ['d'] ["device"]
      (flip ReqArg "NAME" $ \str flags ->
         return $ flags{device = str})
      "select ALSA output device" :
   Option [] ["clientname"]
      (flip ReqArg "NAME" $ \str flags ->
         return $ flags{clientName = ClientName str})
      "name of the ALSA client" :
   Option ['r'] ["samplerate"]
      (flip ReqArg "RATE" $ \str flags ->
         fmap (\rate -> flags{sampleRate = Just $ SampleRate $ fromInteger rate}) $
         parseNumber "sample-rate" (\n -> 0<n && n<=maxInt) "positive" str)
      "sample-rate in samples per second" :
   Option ['b'] ["blocksize"]
      (flip ReqArg "SIZE" $ \str flags ->
         fmap (\size -> flags{chunkSize = SVL.ChunkSize $ fromInteger size}) $
         parseNumber "blocksize" (\n -> 0<n && n<=maxInt) "positive" str)
      "block size as number of sample-frames" :
   Option [] ["latency"]
      (flip ReqArg "SIZE" $ \str flags ->
         fmap (\size -> flags{latency = fromInteger size}) $
         parseNumber "latency" (\n -> 0<=n && n<=maxInt) "non-negative" str)
      "latency as number of sample-frames" :
   Option ['c'] ["channel"]
      (flip ReqArg "CHANNEL" $ \str flags ->
         fmap (\chan -> flags{channel = chan}) $
         parseChannel str)
      "select MIDI input channel (0-based)" :
   Option [] ["extra-channel"]
      (flip ReqArg "CHANNEL" $ \str flags ->
         fmap (\chan -> flags{extraChannel = chan}) $
         parseChannel str)
      "select MIDI channel with effects" :
   Option ['I'] ["sample-directory"]
      (flip ReqArg "DIR" $ \str flags ->
         return $ flags{sampleDirectory = str})
      "directory for sound samples" :
   []


get :: IO T
get = do
   argv <- getArgs
   let (opts, files, errors) = getOpt RequireOrder description argv
   when (not $ null errors) $
      exitFailureMsg (init (concat errors))
   when (not $ null files) $
      exitFailureMsg $
         "Do not know what to do with arguments " ++ show files
   foldl (>>=) (return deflt) opts