Option.hs

-- the options defined here overlap with the ALSA options
module Synthesizer.LLVM.Server.Option (
   T(..),
   get,
   defaultChannel,
   defaultSampleRate,
   ) where

import Synthesizer.LLVM.Server.Common (SampleRate(SampleRate), )
import qualified Data.StorableVector.Lazy       as SVL

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 {
      channel, extraChannel :: ChannelMsg.Channel,
      sampleDirectory :: FilePath,
      sampleRate :: SampleRate Int,
      chunkSize :: SVL.ChunkSize,
      volume :: Float
   }
   deriving (Show)


deflt :: T
deflt =
   Cons {
      channel = defaultChannel,
      extraChannel = ChannelMsg.toChannel 1,
      sampleDirectory = "speech",
      sampleRate = SampleRate defaultSampleRate,
      chunkSize = SVL.chunkSize (128*1024),
      volume = 0.2
   }


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

defaultSampleRate :: Num a => a
defaultSampleRate = 44100



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] infile.mid [outfile.wav]") description)
         exitSuccess)
      "show options" :
   Option ['r'] ["samplerate"]
      (flip ReqArg "RATE" $ \str flags ->
         fmap (\rate -> flags{sampleRate = 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 ['v'] ["volume"]
      (flip ReqArg "FACTOR" $ \str flags ->
         fmap (\x -> flags{volume = x}) $
         parseNumber "volume" (const True) "any" str)
      "block size 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, String, Maybe String)
get = do
   argv <- getArgs
   let (opts, files, errors) = getOpt RequireOrder description argv
   when (not $ null errors) $
      exitFailureMsg (init (concat errors))
   opt <- foldl (>>=) (return deflt) opts
   case files of
      [] -> exitFailureMsg "need MIDI input file"
      [midiPath] -> return (opt, midiPath, Nothing)
      [midiPath, wavePath] -> return (opt, midiPath, Just wavePath)
      _ -> exitFailureMsg "too many file names given"