module Server.Option (
   T(..),
   get,
   printVerbose,
   ) where

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, )


data T =
   Cons {
      verbosity :: Int,
      port :: Int
   }
   deriving (Show)


deflt :: T
deflt =
   Cons {
      verbosity = 0,
      port = 8080
      -- other options might control maximum values for some dimensions in the games
   }


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

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 " ++ constraintName
      _ ->
         exitFailureMsg $ name ++ " must be a number, but is '" ++ str ++ "'"


printVerbose :: (Show a) => T -> Int -> a -> IO ()
printVerbose opt verb a =
   when (verb <= verbosity opt) $ print a


{-
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 ['v'] ["verbose"]
      (flip ReqArg "LEVEL" $ \str flags ->
         fmap (\verb -> flags{verbosity = fromInteger verb}) $
         parseNumber "verbosity" (\n -> 0<=n && n<=2) "from the range from 0 to 2" str)
      "level of verbosity" :
   Option ['p'] ["port"]
      (flip ReqArg "NUMBER" $ \str flags ->
         fmap (\p -> flags{port = fromInteger p}) $
         parseNumber "port" (\n -> 0<n && n<0x10000) "a positive 16-bit number" str)
      "port number" :
   []


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