Option.hs

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

import qualified Synthesizer.Storable.ALSA.Play as Play
import qualified Synthesizer.Generic.Signal     as SigG
import qualified Data.StorableVector.Lazy       as SVL
import Synthesizer.EventList.ALSA.MIDI (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 qualified NumericPrelude.Numeric as NP
import Prelude hiding (Real, )


data T =
   Cons {
      device :: Play.Device,
      clientName :: ClientName,
      channel, extraChannel :: ChannelMsg.Channel,
      sampleDirectory :: FilePath,
      sampleRateInt :: SampleRate Integer,
      chunkSize :: SVL.ChunkSize,
      lazySize :: SigG.LazySize,
      periodTime :: Double,
      latency :: Int
   }
   deriving (Show)


deflt :: T
deflt =
   Cons {
      device = Play.defaultDevice,
      clientName = defaultClientName,
      channel = defaultChannel,
      extraChannel = ChannelMsg.toChannel 1,
      sampleDirectory = "speech",
      sampleRateInt = SampleRate defaultSampleRate,
      chunkSize = Play.defaultChunkSize,
      lazySize = error "Option.lazySize must be initialized after option parsing",
      periodTime = error "Option.periodTime must be initialized after option parsing",
      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


newtype SampleRate a = SampleRate a
   deriving (Show)

instance Functor SampleRate where
   fmap f (SampleRate sr) = SampleRate (f sr)


sampleRate :: Num a => T -> SampleRate a
sampleRate = fmap fromInteger . sampleRateInt


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{sampleRateInt = SampleRate 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
   fmap
      (\actual ->
         case chunkSize actual of
            SVL.ChunkSize size ->
               actual {
                  lazySize = SigG.LazySize size,
                  periodTime =
                     NP.fromIntegral size NP./
                     case sampleRate actual of SampleRate sr -> sr
               }) $
      foldl (>>=)
         (return deflt)
         opts