Option.hs

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

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 {
      clientName :: ClientName,
      channel, extraChannel :: ChannelMsg.Channel,
      sampleDirectory :: FilePath
   }
   deriving (Show)


deflt :: T
deflt =
   Cons {
      clientName = defaultClientName,
      channel = defaultChannel,
      extraChannel = ChannelMsg.toChannel 1,
      sampleDirectory = "speech"
   }


newtype ClientName = ClientName String
   deriving (Show)

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

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



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 ++ "'"

{-
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 [] ["clientname"]
      (flip ReqArg "NAME" $ \str flags ->
         return $ flags{clientName = ClientName str})
      "name of the JACK client" :
   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