{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}

-- |
-- Description : Option processing
--
-- The WBFiles module is in charge of decoding information from the command
-- line and making it available to the rest of the UniForM workbench.
--
-- All UniForM options have names beginning with "--uni".  It is hoped
-- that this won't be a problem for programs that use the UniForM workbench.
-- However, if it is, the function
--    setAlternateArgs
-- should be called before any of the functions in the UniForM workbench,
-- as this will prevent the program arguments being read by UniForM.
--
-- The
-- @
--    --uni
-- @
-- option prints a help message, as do other options beginning with
-- --uni which are not understood.
--
-- The
-- @
--    --uni-parameters
-- @
-- option prints the parameters at the given position on the command
-- line.
--
-- The
-- @
--    --uni-version
-- @
-- option prints the current version of uni.
--
-- @
-- --uni-<option-name>:<option-value>
-- @
-- or equivalently
-- @
-- --uni-<option-name>=<option-value>
-- @
--
-- All options can also be overridden by environment variables.
-- The environment variable corresponding to <option-name> has the
-- name @UNI<OPTION-NAME>@
-- where @<OPTION-NAME>@ is the capitalised name of the option.
--
-- The default set of options are as follows:
--
-- option-name   explanation
--
-- wish          The filename of the wish program
-- daVinci       The filename of daVinci
-- gnuclient     The filename of gnuclient
-- editor        A command to execute the text editor.
--               This uses the CommandStringSub format, with defined
--               substitutions %F => where the file is to be found and
--               %N => what the user-visible name (for example, of the
--               buffer) should be.
-- top           The directory in which UniForM is installed
--
-- daVinciIcons  The directory containing daVinci icons
--
-- workingDir    The directory used for temporary files.
--
-- server        The host name of the server
-- user          The user-id to use connecting to the server
-- password      The password to use connecting to the server
-- port          The port on the server to connect to
-- xmlPort       The port for the XML server (which has a different default)
--
-- debug         Where Debug.debug messages should go
--
-- serverDir     Where Server stores its files
-- serverId      The unique identifier of the server.
--               Since this really does have to be globally unique,
--               it is by default constructed from a combination
--               of the machine's hostname and the server port.
--               You had better not change it unless you know what
--               you are doing.
--
-- MMiSSDTD      Location of DTD file for MMiSS.
--
-- hosts         Location of hosts file.
--
-- toolTimeOut   Time-out waiting for responses from a tool when
--               it starts up and we are doing challenge-response
--               verification.
-- windowsTick   (Windows only) time in microseconds we wait between
--               polling Wish.
--
-- The options wish, daVinci, daVinciIcons, top
-- should all be set automatically by the configure procedure.
-- The configure procedure constructs a variable DEFAULTOPTIONS
-- and writes it into the file default_options.c.
--
-- returns a string with exactly the same syntax as the command line
-- so a typical one might be
--    @
--    --uni-wish:/usr/bin/wish --uni-daVinci:/usr/bin/daVinci
--    @
--    ... (and so on)
--
-- However one difference is that options which are not understood
-- in the default_options string are simply ignored.
module Util.WBFiles (
   -- Functions for reading the results of initialising WBFiles.
   -- Values for which we provide defaults either here or in the
   -- configuration file can be accessed without Maybe.
   getWishPath, -- :: IO String
      -- gets the path for wish
   getDaVinciPath,
      -- ditto daVinci
   getGnuClientPath,
      -- ditto gnuclient.

   getToolTimeOut, -- :: IO Int
      -- gets tool time out.
   getTOP, --  :: IO String
      -- Get the location of the top directory.
   getTOPPath,
      -- :: [String] -> IO String
      -- Get a path within the top directory.
   getEditorString, -- :: IO (Maybe String)
      -- returns editor string, if set.
   getMMiSSDTD, -- :: IO (Maybe String)
      -- returns location of MMiSSDTD, if set.
   getMMiSSAPIDTD, -- :: IO (Maybe String)
      -- returns location of DTD for API requests, if set.
      -- (does not correspond to an option at present, we get it from TOP)

   getHosts, -- :: IO String
      -- returns location of hosts file.

   getPort, -- IO Int

   getXMLPort, -- IO Int

   getCouplingPort, -- IO Int

   -- getWorkingDir trims a right-file-separator from its argument, if any.
   getWorkingDir, -- :: IO String

   getCouplingDir, -- :: IO String

   -- getDebugFileName returns the name of the debug file.
   getDebugFileName, -- IO String

   -- values for which we don't are:
   getDaVinciIcons, -- :: IO (Maybe String)
   getServer, -- ditto
   getUser, -- ditto
   getPassword, -- ditto

   -- Store options.
   getServerFile, -- :: String -> IO String
      -- Get a file for the use of the server.
   getServerDir, --  :: IO String
      -- Get the server's private directory.
   getServerId, -- :: IO (Maybe String)
      -- Return a (globally unique) id for this server.

   -- Access to other options.
   getArgString, -- :: String -> IO (Maybe String)
   getArgBool, -- :: String -> IO (Maybe Bool)
   getArgInt, -- :: String -> IO (Maybe Int)

   -- Functions for initialising WBFiles.  If they detect an error
   -- in the parse, they immediately do System.exitWith (ExitFailure 4).
   -- If the --uni option is used, they do System.exitWith (ExitSuccess)
   -- (after displaying a help message).
   -- If none of these functions are used, the arguments are parsed when
   -- we first try to access them, with the same effect as parseArguments
   -- except that we don't exit if there's a problem.
   --
   parseArguments, -- :: IO ()
       -- equivalent to parseTheseArguments usualProgramArguments.
       -- parseArguments is done by default
   parseArgumentsRequiring, -- :: [String] -> IO ()
       -- equivalent to parseTheseArgumentsRequiring usualProgramArguments.

   ArgType(..), -- represents type arguments can have.
   ArgValue(..), -- represents values arguments can have.

   ProgramArgument(..), -- data corresponding to a single sort of argument.

   usualProgramArguments,
      -- :: [ProgramArgument]
      -- corresponds to the usual program arguments.

   parseTheseArguments, -- :: [ProgramArgument] -> IO ()
   -- parseTheseArguments args = parseTheseArgumentsRequiring args []

   parseTheseArgumentsRequiring, -- :: [ProgramArgument] -> [String] -> IO ()
   -- parseTheseArgumentsRequiring
   -- parses the arguments, using the supplied list of allowed arguments.
   -- It is an error if any of the options with names in the second argument
   -- are not defined.

   setAlternateArgs -- :: [String] -> IO ()
   -- specify the given strings as arguments to be used by the parse
   -- functions.

   ) where

import Data.Char
import Util.CompileFlags
import System.IO
import Data.List
import Control.Monad
import qualified System.Environment as System
import System.Exit(exitWith,ExitCode(..))

import qualified Control.Exception as Exception
import Control.Concurrent
import qualified Data.Map as Map
import System.IO.Unsafe
import Foreign.C.String

import Util.FileNames

------------------------------------------------------------------------
-- Specific access functions.
------------------------------------------------------------------------

valOf :: String -> IO (Maybe a) -> IO a
valOf :: String -> IO (Maybe a) -> IO a
valOf String
optionName IO (Maybe a)
action =
   do
      Maybe a
valueOpt <- IO (Maybe a)
action
      case Maybe a
valueOpt of
         Just a
a -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
         Maybe a
Nothing ->
            String -> IO a
forall a. HasCallStack => String -> a
error (String
"option --uni-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optionName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is surprisingly unset")

getWishPath :: IO String
getWishPath :: IO String
getWishPath = String -> IO (Maybe String) -> IO String
forall a. String -> IO (Maybe a) -> IO a
valOf String
"wish" (String -> IO (Maybe String)
getArgString String
"wish")

getEditorString :: IO (Maybe String)
getEditorString :: IO (Maybe String)
getEditorString = String -> IO (Maybe String)
getArgString String
"editor"

getMMiSSDTD :: IO (Maybe String)
getMMiSSDTD :: IO (Maybe String)
getMMiSSDTD =
   do
      Maybe String
mmissDTDOpt <- String -> IO (Maybe String)
getArgString String
"MMiSSDTD"
      case Maybe String
mmissDTDOpt of
         Just String
mmissDTD -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
mmissDTDOpt
         Maybe String
Nothing ->
            do
               String
path <- [String] -> IO String
getTOPPath [String
"mmiss",String
"MMiSS.dtd"]
               Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
path)

getMMiSSAPIDTD :: IO (Maybe String)
getMMiSSAPIDTD :: IO (Maybe String)
getMMiSSAPIDTD =
   do
      String
path <- [String] -> IO String
getTOPPath [String
"mmiss",String
"api",String
"MMiSSRequest.dtd"]
      Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
path)

      -- returns location of DTD for API requests, if set.

getHosts :: IO String
getHosts :: IO String
getHosts =
   do
      Maybe String
hostsOpt <- String -> IO (Maybe String)
getArgString String
"Hosts"
      case Maybe String
hostsOpt of
         Just String
hosts -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
hosts
         Maybe String
Nothing ->
            [String] -> IO String
getTOPPath [String
"server",String
"Hosts.xml"]


getDaVinciPath :: IO String
getDaVinciPath :: IO String
getDaVinciPath = String -> IO (Maybe String) -> IO String
forall a. String -> IO (Maybe a) -> IO a
valOf String
"daVinci" (String -> IO (Maybe String)
getArgString String
"daVinci")

getGnuClientPath :: IO String
getGnuClientPath :: IO String
getGnuClientPath = String -> IO (Maybe String) -> IO String
forall a. String -> IO (Maybe a) -> IO a
valOf String
"gnuclient" (String -> IO (Maybe String)
getArgString String
"gnuclient")

getToolTimeOut :: IO Int
getToolTimeOut :: IO Int
getToolTimeOut = String -> IO (Maybe Int) -> IO Int
forall a. String -> IO (Maybe a) -> IO a
valOf String
"toolTimeOut" (String -> IO (Maybe Int)
getArgInt String
"toolTimeOut")

getTOP :: IO String
getTOP :: IO String
getTOP = String -> IO (Maybe String) -> IO String
forall a. String -> IO (Maybe a) -> IO a
valOf String
"top" (String -> IO (Maybe String)
getArgString String
"top")

-- | Get a path within the top directory.
getTOPPath :: [String] -> IO String
getTOPPath :: [String] -> IO String
getTOPPath [String]
names =
   do
      String
top <- IO String
getTOP
      String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> String
unbreakName (String -> String
trimDir String
topString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
names))

getPort :: IO Int
getPort :: IO Int
getPort = String -> IO (Maybe Int) -> IO Int
forall a. String -> IO (Maybe a) -> IO a
valOf String
"port" (String -> IO (Maybe Int)
getArgInt String
"port")

getXMLPort :: IO Int
getXMLPort :: IO Int
getXMLPort = String -> IO (Maybe Int) -> IO Int
forall a. String -> IO (Maybe a) -> IO a
valOf String
"xmlPort" (String -> IO (Maybe Int)
getArgInt String
"xmlPort")

getWorkingDir :: IO String
getWorkingDir :: IO String
getWorkingDir =
   do
      String
workingDir' <- String -> IO (Maybe String) -> IO String
forall a. String -> IO (Maybe a) -> IO a
valOf String
"workingDir" (String -> IO (Maybe String)
getArgString String
"workingDir")
      String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
trimDir String
workingDir')

getDebugFileName :: IO String
getDebugFileName :: IO String
getDebugFileName = String -> IO (Maybe String) -> IO String
forall a. String -> IO (Maybe a) -> IO a
valOf String
"debug" (String -> IO (Maybe String)
getArgString String
"debug")

getServerFile :: String -> IO String
getServerFile :: String -> IO String
getServerFile String
innerName =
   do
      String
serverDir <- IO String
getServerDir
      String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> String
combineNames (String -> String
trimDir String
serverDir) String
innerName)

getServerDir :: IO String
getServerDir :: IO String
getServerDir =
   do
      Maybe String
serverDirOpt <- String -> IO (Maybe String)
getArgString String
"serverDir"
      case Maybe String
serverDirOpt of
         Maybe String
Nothing ->
            String -> IO String
forall a. HasCallStack => String -> a
error (
               String
"UNISERVERDIR environment variable or --uni-serverDir"
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must be set for server programs")
         Just String
serverDir -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
serverDir

getServerId :: IO (Maybe String)
getServerId :: IO (Maybe String)
getServerId = String -> IO (Maybe String)
getArgString String
"serverId"


getDaVinciIcons :: IO (Maybe String)
getDaVinciIcons :: IO (Maybe String)
getDaVinciIcons = String -> IO (Maybe String)
getArgString String
"daVinciIcons"

getServer :: IO (Maybe String)
getServer :: IO (Maybe String)
getServer = String -> IO (Maybe String)
getArgString String
"server"

getUser :: IO (Maybe String)
getUser :: IO (Maybe String)
getUser = String -> IO (Maybe String)
getArgString String
"user"

getPassword :: IO (Maybe String)
getPassword :: IO (Maybe String)
getPassword = String -> IO (Maybe String)
getArgString String
"password"

getCouplingPort :: IO Int
getCouplingPort :: IO Int
getCouplingPort = String -> IO (Maybe Int) -> IO Int
forall a. String -> IO (Maybe a) -> IO a
valOf String
"couplingPort" (String -> IO (Maybe Int)
getArgInt String
"couplingPort")

getCouplingDir ::  IO String
getCouplingDir :: IO String
getCouplingDir = String -> IO (Maybe String) -> IO String
forall a. String -> IO (Maybe a) -> IO a
valOf String
"couplingDir" (String -> IO (Maybe String)
getArgString String
"couplingDir")


------------------------------------------------------------------------
-- ProgramArgument and usualProgramArguments.
------------------------------------------------------------------------

data ProgramArgument = ProgramArgument {
   ProgramArgument -> String
optionName :: String, -- the option name
   ProgramArgument -> String
optionHelp :: String, -- Help text displayed by --uni option.
   ProgramArgument -> Maybe ArgValue
defaultVal :: Maybe ArgValue, -- default value
   ProgramArgument -> ArgType
argType :: ArgType
   }

usualProgramArguments :: [ProgramArgument]
usualProgramArguments :: [ProgramArgument]
usualProgramArguments = [
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"wish",
      optionHelp :: String
optionHelp = String
"path to the wish program",
      defaultVal :: Maybe ArgValue
defaultVal = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (String -> ArgValue
StringValue String
"/usr/bin/wish"),
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"daVinci",
      optionHelp :: String
optionHelp = String
"path to the daVinci program",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"daVinciIcons",
      optionHelp :: String
optionHelp = String
"directory containing daVinci icons",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"gnuclient",
      optionHelp :: String
optionHelp = String
"path to the gnuclient program",
      defaultVal :: Maybe ArgValue
defaultVal = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (String -> ArgValue
StringValue String
"gnuclient"),
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"toolTimeOut",
      optionHelp :: String
optionHelp = String
"time-out when tools start up in milliseconds",
      defaultVal :: Maybe ArgValue
defaultVal = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (Int -> ArgValue
IntValue Int
10000),
      argType :: ArgType
argType = ArgType
INT
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"windowsTick",
      optionHelp :: String
optionHelp = String
"interval in microseconds for polling wish (Windows only).",
      defaultVal :: Maybe ArgValue
defaultVal = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (Int -> ArgValue
IntValue Int
10000),
      argType :: ArgType
argType = ArgType
INT
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"editor",
      optionHelp :: String
optionHelp = String
"text editor cmd; %F => filename; %N => user-visible name",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      -- We make getMMiSSDTD return a default of TOP/mmiss/MMiSS.dtd if
      -- nothing is set.
      optionName :: String
optionName = String
"MMiSSDTD",
      optionHelp :: String
optionHelp = String
"Filename for MMiSS's DTD",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      -- We make getHosts return a default of TOP/server/Hosts.xml if
      -- Nothing is set.
      optionName :: String
optionName = String
"Hosts",
      optionHelp :: String
optionHelp = String
"File containing list of hosts",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"top",
      optionHelp :: String
optionHelp = String
"path where UniForM was installed",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"serverDir",
      optionHelp :: String
optionHelp = String
"where server stores its files",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"serverId",
      optionHelp :: String
optionHelp = String
"globally unique server identifier (EXPERTS ONLY)",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"workingDir",
      optionHelp :: String
optionHelp = String
"directory used for temporary files",
      defaultVal :: Maybe ArgValue
defaultVal = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (String -> ArgValue
StringValue String
"/tmp"),
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"server",
      optionHelp :: String
optionHelp = String
"machine where the server runs",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"user",
      optionHelp :: String
optionHelp = String
"Your identifier on the server",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"password",
      optionHelp :: String
optionHelp = String
"Your password on the server",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"port",
      optionHelp :: String
optionHelp = String
"port for the server",
      defaultVal :: Maybe ArgValue
defaultVal = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (Int -> ArgValue
IntValue Int
defaultPort),
      argType :: ArgType
argType = ArgType
INT
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"xmlPort",
      optionHelp :: String
optionHelp = String
"port for the MMiSS-XML server",
      defaultVal :: Maybe ArgValue
defaultVal = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (Int -> ArgValue
IntValue Int
defaultXMLPort),
      argType :: ArgType
argType = ArgType
INT
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"couplingPort",
      optionHelp :: String
optionHelp = String
"port for the coupling server",
      defaultVal :: Maybe ArgValue
defaultVal = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (Int -> ArgValue
IntValue Int
defaultCouplingPort),
      argType :: ArgType
argType = ArgType
INT
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"couplingDir",
      optionHelp :: String
optionHelp = String
"directory where the coupling server finds the working copy of foreign repository",
      defaultVal :: Maybe ArgValue
defaultVal = Maybe ArgValue
forall a. Maybe a
Nothing,
      argType :: ArgType
argType = ArgType
STRING
      },
   ProgramArgument :: String -> String -> Maybe ArgValue -> ArgType -> ProgramArgument
ProgramArgument{
      optionName :: String
optionName = String
"debug",
      optionHelp :: String
optionHelp = String
"file for debug output",
      defaultVal :: Maybe ArgValue
defaultVal = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (String -> ArgValue
StringValue String
"/tmp/uniform.DEBUG"),
      argType :: ArgType
argType = ArgType
STRING
      }
   ]

defaultPort :: Int
defaultPort :: Int
defaultPort = Int
11393


defaultXMLPort :: Int
defaultXMLPort :: Int
defaultXMLPort = Int
11396

defaultCouplingPort :: Int
defaultCouplingPort :: Int
defaultCouplingPort = Int
11391

------------------------------------------------------------------------
-- Argument Types
------------------------------------------------------------------------

data ArgType = STRING | INT | BOOL

showArgType :: ArgType -> String
showArgType :: ArgType -> String
showArgType ArgType
STRING = String
"string"
showArgType ArgType
INT = String
"int"
showArgType ArgType
BOOL = String
"bool"

data ArgValue = StringValue String | IntValue Int | BoolValue Bool

parseArgValue :: ArgType -> String -> Maybe ArgValue
parseArgValue :: ArgType -> String -> Maybe ArgValue
parseArgValue ArgType
STRING String
str = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (String -> ArgValue
StringValue String
str)
parseArgValue ArgType
INT String
str =
   case Int -> ReadS Int
forall a. Read a => Int -> ReadS a
readsPrec Int
0 String
str of
      [(Int
val,String
"")] -> ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (Int -> ArgValue
IntValue Int
val)
      [(Int, String)]
_ -> Maybe ArgValue
forall a. Maybe a
Nothing
parseArgValue ArgType
BOOL String
str =
   let
      true :: Maybe ArgValue
true = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (Bool -> ArgValue
BoolValue Bool
True)
      false :: Maybe ArgValue
false = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (Bool -> ArgValue
BoolValue Bool
False)
   in
      case String
str of
         String
"" -> Maybe ArgValue
true
         String
"True" -> Maybe ArgValue
true
         String
"False" -> Maybe ArgValue
false
         String
"+" -> Maybe ArgValue
true
         String
"-" -> Maybe ArgValue
false
         String
"yes" -> Maybe ArgValue
true
         String
"no" -> Maybe ArgValue
false
         String
_ -> Maybe ArgValue
forall a. Maybe a
Nothing

showArgValue :: ArgValue -> String
showArgValue :: ArgValue -> String
showArgValue (StringValue String
str) = String
str
showArgValue (IntValue Int
i) = Int -> String
forall a. Show a => a -> String
show Int
i
showArgValue (BoolValue Bool
b) = if Bool
b then String
"+" else String
"-"

------------------------------------------------------------------------
-- Parsed Arguments
------------------------------------------------------------------------

newtype ParsedArguments =
   ParsedArguments (MVar (Maybe (Map.Map String ArgValue)))

makeParsedArguments :: IO ParsedArguments
makeParsedArguments :: IO ParsedArguments
makeParsedArguments =
   do
      MVar (Maybe (Map String ArgValue))
mVar <- Maybe (Map String ArgValue)
-> IO (MVar (Maybe (Map String ArgValue)))
forall a. a -> IO (MVar a)
newMVar Maybe (Map String ArgValue)
forall a. Maybe a
Nothing
      ParsedArguments -> IO ParsedArguments
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar (Maybe (Map String ArgValue)) -> ParsedArguments
ParsedArguments MVar (Maybe (Map String ArgValue))
mVar)
{-# NOINLINE makeParsedArguments #-}
-- the NOINLINE should, we hope, mean that there is only one copy of
-- the parsedArguments mVar.

parsedArguments :: ParsedArguments
-- the unique set of parsed arguments
parsedArguments :: ParsedArguments
parsedArguments = IO ParsedArguments -> ParsedArguments
forall a. IO a -> a
unsafePerformIO IO ParsedArguments
makeParsedArguments
{-# NOINLINE parsedArguments #-}

getArgValue :: String -> IO (Maybe ArgValue)
getArgValue :: String -> IO (Maybe ArgValue)
getArgValue String
optionName =
   do
      Map String ArgValue
map <- IO (Map String ArgValue)
forceParseArguments
      Maybe ArgValue -> IO (Maybe ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Map String ArgValue -> Maybe ArgValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
optionName Map String ArgValue
map)

mismatch :: String -> a
mismatch :: String -> a
mismatch String
optionName =
   String -> a
forall a. HasCallStack => String -> a
error (String
"WBFiles.mismatch - type mismatch for "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
optionName)
   -- If this happens, it means a bug in this file or else
   -- a default value for a program argument does not have the right type,
   -- or an attempt to use a getArg* function for an option with the wrong
   -- type.
{-# NOINLINE mismatch #-}

getArgString :: String -> IO (Maybe String)
getArgString :: String -> IO (Maybe String)
getArgString String
optionName =
   do
      Maybe ArgValue
valOpt <- String -> IO (Maybe ArgValue)
getArgValue String
optionName
      case Maybe ArgValue
valOpt of
         Just (StringValue String
str) -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
str)
         Just ArgValue
_ -> String -> IO (Maybe String)
forall a. String -> a
mismatch String
optionName
         Maybe ArgValue
Nothing -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

getArgInt :: String -> IO (Maybe Int)
getArgInt :: String -> IO (Maybe Int)
getArgInt String
optionName =
   do
      Maybe ArgValue
valOpt <- String -> IO (Maybe ArgValue)
getArgValue String
optionName
      case Maybe ArgValue
valOpt of
         Just (IntValue Int
i) -> Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i)
         Just ArgValue
_ -> String -> IO (Maybe Int)
forall a. String -> a
mismatch String
optionName
         Maybe ArgValue
Nothing -> Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing


getArgBool :: String -> IO (Maybe Bool)
getArgBool :: String -> IO (Maybe Bool)
getArgBool String
optionName =
   do
      Maybe ArgValue
valOpt <- String -> IO (Maybe ArgValue)
getArgValue String
optionName
      case Maybe ArgValue
valOpt of
         Just (BoolValue Bool
b) -> Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b)
         Just ArgValue
_ -> String -> IO (Maybe Bool)
forall a. String -> a
mismatch String
optionName
         Maybe ArgValue
Nothing -> Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing


-- forceParseArguments is used to force a parse of the arguments
-- when no parse function has been called before.
forceParseArguments :: IO (Map.Map String ArgValue)
forceParseArguments :: IO (Map String ArgValue)
forceParseArguments =
   do
      let ParsedArguments MVar (Maybe (Map String ArgValue))
mVar = ParsedArguments
parsedArguments
      Maybe (Map String ArgValue)
mapOpt <- MVar (Maybe (Map String ArgValue))
-> IO (Maybe (Map String ArgValue))
forall a. MVar a -> IO a
takeMVar MVar (Maybe (Map String ArgValue))
mVar
      case Maybe (Map String ArgValue)
mapOpt of
         Maybe (Map String ArgValue)
Nothing ->
            do
               (Maybe ExitCode
exitCode,Map String ArgValue
newMap) <-
                  [ProgramArgument]
-> [String] -> IO (Maybe ExitCode, Map String ArgValue)
parseTheseArgumentsRequiring' [ProgramArgument]
usualProgramArguments []
               MVar (Maybe (Map String ArgValue))
-> Maybe (Map String ArgValue) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe (Map String ArgValue))
mVar (Map String ArgValue -> Maybe (Map String ArgValue)
forall a. a -> Maybe a
Just Map String ArgValue
newMap)
               Map String ArgValue -> IO (Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return Map String ArgValue
newMap
         Just Map String ArgValue
map ->
            do
               MVar (Maybe (Map String ArgValue))
-> Maybe (Map String ArgValue) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe (Map String ArgValue))
mVar (Map String ArgValue -> Maybe (Map String ArgValue)
forall a. a -> Maybe a
Just Map String ArgValue
map)
               Map String ArgValue -> IO (Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return Map String ArgValue
map

------------------------------------------------------------------------
-- setAlternateArgs
------------------------------------------------------------------------

alternateArgs :: MVar [String]

newAlternateArgs :: IO (MVar [String])
newAlternateArgs :: IO (MVar [String])
newAlternateArgs = IO (MVar [String])
forall a. IO (MVar a)
newEmptyMVar
{-# NOINLINE newAlternateArgs #-}

alternateArgs :: MVar [String]
alternateArgs = IO (MVar [String]) -> MVar [String]
forall a. IO a -> a
unsafePerformIO IO (MVar [String])
newAlternateArgs

setAlternateArgs :: [String] -> IO ()
setAlternateArgs :: [String] -> IO ()
setAlternateArgs [String]
newArgs =
   do
      Bool
isEmpty <- MVar [String] -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar [String]
alternateArgs
      if Bool
isEmpty
         then
            MVar [String] -> [String] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [String]
alternateArgs [String]
newArgs
         else
            String -> IO ()
forall a. HasCallStack => String -> a
error String
"setAlternateArgs called twice or after getArgs"

getArgs :: IO [String]
getArgs :: IO [String]
getArgs =
   do
      Bool
isEmpty <- MVar [String] -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar [String]
alternateArgs
      [String]
args <- if Bool
isEmpty
         then
            IO [String]
System.getArgs
         else
            MVar [String] -> IO [String]
forall a. MVar a -> IO a
takeMVar MVar [String]
alternateArgs
      MVar [String] -> [String] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [String]
alternateArgs [String]
args
      [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
args

------------------------------------------------------------------------
-- Parsing Arguments
------------------------------------------------------------------------

parseArguments :: IO ()
parseArguments :: IO ()
parseArguments = [ProgramArgument] -> IO ()
parseTheseArguments [ProgramArgument]
usualProgramArguments

parseArgumentsRequiring :: [String] -> IO ()
parseArgumentsRequiring :: [String] -> IO ()
parseArgumentsRequiring [String]
required =
   [ProgramArgument] -> [String] -> IO ()
parseTheseArgumentsRequiring [ProgramArgument]
usualProgramArguments [String]
required

parseTheseArguments :: [ProgramArgument] -> IO ()
parseTheseArguments :: [ProgramArgument] -> IO ()
parseTheseArguments [ProgramArgument]
arguments = [ProgramArgument] -> [String] -> IO ()
parseTheseArgumentsRequiring [ProgramArgument]
arguments []

parseTheseArgumentsRequiring :: [ProgramArgument] -> [String] -> IO ()
parseTheseArgumentsRequiring :: [ProgramArgument] -> [String] -> IO ()
parseTheseArgumentsRequiring [ProgramArgument]
arguments [String]
required =
   do
      let ParsedArguments MVar (Maybe (Map String ArgValue))
mVar = ParsedArguments
parsedArguments
      Maybe (Map String ArgValue)
mapOpt <- MVar (Maybe (Map String ArgValue))
-> IO (Maybe (Map String ArgValue))
forall a. MVar a -> IO a
takeMVar MVar (Maybe (Map String ArgValue))
mVar
      case Maybe (Map String ArgValue)
mapOpt of
         Just Map String ArgValue
_ ->
            do
               MVar (Maybe (Map String ArgValue))
-> Maybe (Map String ArgValue) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe (Map String ArgValue))
mVar Maybe (Map String ArgValue)
mapOpt
               String -> IO ()
printToErr
                  (String
"WBFiles.parseTheseArgumentsRequiring: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String
"attempt to parse arguments too late")
         Maybe (Map String ArgValue)
Nothing ->
            do
               (Maybe ExitCode
result,Map String ArgValue
newMap) <-
                  [ProgramArgument]
-> [String] -> IO (Maybe ExitCode, Map String ArgValue)
parseTheseArgumentsRequiring' [ProgramArgument]
arguments [String]
required
               MVar (Maybe (Map String ArgValue))
-> Maybe (Map String ArgValue) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe (Map String ArgValue))
mVar (Map String ArgValue -> Maybe (Map String ArgValue)
forall a. a -> Maybe a
Just Map String ArgValue
newMap)
               case Maybe ExitCode
result of
                  Maybe ExitCode
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Just ExitCode
exitCode -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
exitCode


type ParseState = (Maybe ExitCode,Map.Map String ArgValue)

parseTheseArgumentsRequiring' :: [ProgramArgument] -> [String] ->
  IO ParseState
-- is the most general argument parsing function, in terms of which
-- all the others are defined.
-- It returns a map representing the parsed arguments, plus an exit
-- code if an exit is indicated.
parseTheseArgumentsRequiring' :: [ProgramArgument]
-> [String] -> IO (Maybe ExitCode, Map String ArgValue)
parseTheseArgumentsRequiring' [ProgramArgument]
arguments [String]
required =
   do
      let
         initialMap :: Map String ArgValue
initialMap =
            (Map String ArgValue -> ProgramArgument -> Map String ArgValue)
-> Map String ArgValue -> [ProgramArgument] -> Map String ArgValue
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
               (\ Map String ArgValue
map ProgramArgument
argument ->
                  case (ProgramArgument -> Maybe ArgValue
defaultVal ProgramArgument
argument) of
                     Maybe ArgValue
Nothing -> Map String ArgValue
map
                     Just ArgValue
value -> String -> ArgValue -> Map String ArgValue -> Map String ArgValue
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ProgramArgument -> String
optionName ProgramArgument
argument) ArgValue
value Map String ArgValue
map
                  )
               Map String ArgValue
forall k a. Map k a
Map.empty
               [ProgramArgument]
arguments

         initial :: (Maybe ExitCode, Map String ArgValue)
initial = (Maybe ExitCode
forall a. Maybe a
Nothing, Map String ArgValue
initialMap) :: ParseState

      String
defaultOptionsStr <- CString -> IO String
peekCString CString
defaultOptions
      (Maybe ExitCode, Map String ArgValue)
afterDefault <- ((Maybe ExitCode, Map String ArgValue)
 -> String -> IO (Maybe ExitCode, Map String ArgValue))
-> (Maybe ExitCode, Map String ArgValue)
-> [String]
-> IO (Maybe ExitCode, Map String ArgValue)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Bool
-> (Maybe ExitCode, Map String ArgValue)
-> String
-> IO (Maybe ExitCode, Map String ArgValue)
handleParameter Bool
False) (Maybe ExitCode, Map String ArgValue)
initial
         (String -> [String]
words String
defaultOptionsStr)

      [String]
parameters <- IO [String]
getArgs

      (Maybe ExitCode, Map String ArgValue)
afterParms <- ((Maybe ExitCode, Map String ArgValue)
 -> String -> IO (Maybe ExitCode, Map String ArgValue))
-> (Maybe ExitCode, Map String ArgValue)
-> [String]
-> IO (Maybe ExitCode, Map String ArgValue)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Bool
-> (Maybe ExitCode, Map String ArgValue)
-> String
-> IO (Maybe ExitCode, Map String ArgValue)
handleParameter Bool
True) (Maybe ExitCode, Map String ArgValue)
afterDefault [String]
parameters

      (Maybe ExitCode, Map String ArgValue)
afterEnvs <- ((Maybe ExitCode, Map String ArgValue)
 -> ProgramArgument -> IO (Maybe ExitCode, Map String ArgValue))
-> (Maybe ExitCode, Map String ArgValue)
-> [ProgramArgument]
-> IO (Maybe ExitCode, Map String ArgValue)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Maybe ExitCode, Map String ArgValue)
-> ProgramArgument -> IO (Maybe ExitCode, Map String ArgValue)
handleEnv (Maybe ExitCode, Map String ArgValue)
afterParms [ProgramArgument]
arguments

      ((Maybe ExitCode, Map String ArgValue)
 -> String -> IO (Maybe ExitCode, Map String ArgValue))
-> (Maybe ExitCode, Map String ArgValue)
-> [String]
-> IO (Maybe ExitCode, Map String ArgValue)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Maybe ExitCode, Map String ArgValue)
-> String -> IO (Maybe ExitCode, Map String ArgValue)
checkReq (Maybe ExitCode, Map String ArgValue)
afterEnvs [String]
required
   where
      handleParameter :: Bool -> ParseState -> String -> IO ParseState
      -- handles a single command line parameter.  If the Bool is true
      -- it modifies the exit code accordingly.
      handleParameter :: Bool
-> (Maybe ExitCode, Map String ArgValue)
-> String
-> IO (Maybe ExitCode, Map String ArgValue)
handleParameter Bool
noticeErrors prev :: (Maybe ExitCode, Map String ArgValue)
prev@(Maybe ExitCode
prevExit,Map String ArgValue
prevMap) String
parameter =
         let
            newExit :: ExitCode -> Maybe ExitCode
newExit ExitCode
exitCode = Bool -> ExitCode -> Maybe ExitCode -> Maybe ExitCode
upgradeError Bool
noticeErrors ExitCode
exitCode Maybe ExitCode
prevExit
            cantParse :: IO (Maybe ExitCode, Map String ArgValue)
cantParse =
               do
                  String -> IO ()
printToErr (String
"Can't parse "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
parameter)
                  IO ()
displayHelp
                  (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> Maybe ExitCode
newExit (Int -> ExitCode
ExitFailure Int
4),Map String ArgValue
prevMap)
         in
            case String
parameter of
               String
"--uni" ->
                  do
                     IO ()
displayHelp
                     (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> Maybe ExitCode
newExit ExitCode
ExitSuccess,Map String ArgValue
prevMap)
               String
"--uni-version" ->
                     do
                        String -> IO ()
printToErr (String
"uni's version is "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
uniVersion)
                        -- The MMiSS installer relies on the exact text of
                        -- this message.
                        (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> Maybe ExitCode
newExit ExitCode
ExitSuccess,Map String ArgValue
prevMap)
               String
"--uni-parameters" ->
                  do
                     Map String ArgValue -> IO ()
displayState Map String ArgValue
prevMap
                     (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> Maybe ExitCode
newExit ExitCode
ExitSuccess,Map String ArgValue
prevMap)
               Char
'-':Char
'-':Char
'u':Char
'n':Char
'i':Char
'-':String
setParm ->
                  case String -> Maybe (String, String)
splitSetPart String
setParm of
                     Maybe (String, String)
Nothing -> IO (Maybe ExitCode, Map String ArgValue)
cantParse
                     Just (String
option,String
value) ->
                        case (ProgramArgument -> Bool)
-> [ProgramArgument] -> Maybe ProgramArgument
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ ProgramArgument
arg -> ProgramArgument -> String
optionName ProgramArgument
arg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
option)
                              [ProgramArgument]
arguments of
                           Maybe ProgramArgument
Nothing ->
                              do
                                 if Bool
noticeErrors
                                    then
                                       do
                                          IO ()
displayHelp
                                          String -> IO ()
printToErr (String
"Option '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
optionString -> String -> String
forall a. [a] -> [a] -> [a]
++
                                             String
"' not recognised")
                                    else
                                       () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                 (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> Maybe ExitCode
newExit (Int -> ExitCode
ExitFailure Int
4),Map String ArgValue
prevMap)
                           Just ProgramArgument
arg ->
                              ArgType
-> String
-> String
-> (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
tryToAddValue (ProgramArgument -> ArgType
argType ProgramArgument
arg) String
option String
value (Maybe ExitCode, Map String ArgValue)
prev
               Char
'-':Char
'-':Char
'u':Char
'n':Char
'i':String
_ -> IO (Maybe ExitCode, Map String ArgValue)
cantParse
               String
_ -> (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExitCode, Map String ArgValue)
prev

      tryToAddValue :: ArgType -> String -> String -> ParseState ->
         IO ParseState
      tryToAddValue :: ArgType
-> String
-> String
-> (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
tryToAddValue ArgType
argType String
option String
value prev :: (Maybe ExitCode, Map String ArgValue)
prev@(Maybe ExitCode
prevExit,Map String ArgValue
prevMap) =
         case ArgType -> String -> Maybe ArgValue
parseArgValue ArgType
argType String
value of
            Maybe ArgValue
Nothing ->
               do
                  String -> IO ()
printToErr(String
"For --uni-"String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
option String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", "String -> String -> String
forall a. [a] -> [a] -> [a]
++(String -> String
forall a. Show a => a -> String
show String
value)String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String
" isn't "String -> String -> String
forall a. [a] -> [a] -> [a]
++ (ArgType -> String
showArgType ArgType
argType))
                  (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return
                     (Bool -> ExitCode -> Maybe ExitCode -> Maybe ExitCode
upgradeError Bool
True (Int -> ExitCode
ExitFailure Int
4) Maybe ExitCode
prevExit,Map String ArgValue
prevMap)
                     -- we always take notice of this error, since it
                     -- shouldn't occur in the default list either.
            Just ArgValue
argValue ->
               (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExitCode
prevExit,String -> ArgValue -> Map String ArgValue -> Map String ArgValue
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
option ArgValue
argValue Map String ArgValue
prevMap)

      splitSetPart :: String -> Maybe (String,String)
      -- splitSetPart splits the string at its first : or = and returns
      -- the result
      splitSetPart :: String -> Maybe (String, String)
splitSetPart String
"" = Maybe (String, String)
forall a. Maybe a
Nothing
      splitSetPart (Char
':':String
rest) = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
"",String
rest)
      splitSetPart (Char
'=':String
rest) = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
"",String
rest)
      splitSetPart (Char
first:String
rest) =
         case String -> Maybe (String, String)
splitSetPart String
rest of
            Maybe (String, String)
Nothing -> Maybe (String, String)
forall a. Maybe a
Nothing
            Just (String
left,String
right) -> (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (Char
firstChar -> String -> String
forall a. a -> [a] -> [a]
:String
left,String
right)

      displayHelp :: IO ()
      -- display a help message
      displayHelp :: IO ()
displayHelp =
         do
            String -> IO ()
printToErr String
"Command-line options:"
            String -> IO ()
printToErr String
"--uni displays this message"
            String -> IO ()
printToErr String
"--uni-version displays the current version"
            String -> IO ()
printToErr String
"--uni-parameters displays option settings"
            [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
               ((ProgramArgument -> IO ()) -> [ProgramArgument] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map
                  (\ (ProgramArgument{optionName :: ProgramArgument -> String
optionName = String
optionName,
                     optionHelp :: ProgramArgument -> String
optionHelp = String
optionHelp,argType :: ProgramArgument -> ArgType
argType = ArgType
argType}) ->
                     String -> IO ()
printToErr (
                        String
"--uni-"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
optionNameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"=["String -> String -> String
forall a. [a] -> [a] -> [a]
++ArgType -> String
showArgType ArgType
argType String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        String
"] sets "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
optionHelp
                        )
                     )
                  [ProgramArgument]
arguments
                  )

      displayState :: Map.Map String ArgValue -> IO ()
      -- displays the current options
      displayState :: Map String ArgValue -> IO ()
displayState Map String ArgValue
fmap =
         do
            let optionValues :: [(String, ArgValue)]
optionValues = Map String ArgValue -> [(String, ArgValue)]
forall k a. Map k a -> [(k, a)]
Map.toList Map String ArgValue
fmap
            String -> IO ()
printToErr String
"Parameter settings:"
            [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
               (((String, ArgValue) -> IO ()) -> [(String, ArgValue)] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map
                  (\ (String
option,ArgValue
argValue) ->
                     String -> IO ()
printToErr (String
"--uni-"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
optionString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"="String -> String -> String
forall a. [a] -> [a] -> [a]
++
                        (ArgValue -> String
showArgValue ArgValue
argValue))
                     )
                  [(String, ArgValue)]
optionValues
                  )

      handleEnv :: ParseState -> ProgramArgument -> IO ParseState
      -- look up the environment variable for the program argument and
      -- adjust state appropriately
      handleEnv :: (Maybe ExitCode, Map String ArgValue)
-> ProgramArgument -> IO (Maybe ExitCode, Map String ArgValue)
handleEnv prev :: (Maybe ExitCode, Map String ArgValue)
prev@(Maybe ExitCode
prevExit,Map String ArgValue
prevMap) ProgramArgument
arg =
         do
            let
               option :: String
option = ProgramArgument -> String
optionName ProgramArgument
arg
               envVar :: String
envVar = String
"UNI"String -> String -> String
forall a. [a] -> [a] -> [a]
++((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
option)
            Either IOException String
valueOpt <- IO String -> IO (Either IOException String)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (String -> IO String
System.getEnv String
envVar)
            case Either IOException String
valueOpt of
               Left (IOException
_ :: Exception.IOException) -> (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExitCode, Map String ArgValue)
prev
               Right String
newValue ->
                  ArgType
-> String
-> String
-> (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
tryToAddValue (ProgramArgument -> ArgType
argType ProgramArgument
arg) String
option String
newValue (Maybe ExitCode, Map String ArgValue)
prev

      checkReq :: ParseState -> String -> IO ParseState
      -- check that the provided option value is set
      checkReq :: (Maybe ExitCode, Map String ArgValue)
-> String -> IO (Maybe ExitCode, Map String ArgValue)
checkReq prev :: (Maybe ExitCode, Map String ArgValue)
prev@(Maybe ExitCode
prevExit,Map String ArgValue
prevMap) String
option =
         case String -> Map String ArgValue -> Maybe ArgValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
option Map String ArgValue
prevMap of
            Just ArgValue
_ -> (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExitCode, Map String ArgValue)
prev
            Maybe ArgValue
Nothing ->
               do
                  String -> IO ()
printToErr (String
"Option "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
optionString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" is not set.")
                  (Maybe ExitCode, Map String ArgValue)
-> IO (Maybe ExitCode, Map String ArgValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ExitCode -> Maybe ExitCode -> Maybe ExitCode
upgradeError Bool
True (Int -> ExitCode
ExitFailure Int
4) Maybe ExitCode
prevExit,Map String ArgValue
prevMap)

      upgradeError :: Bool -> ExitCode -> Maybe ExitCode -> Maybe ExitCode
      -- takes notice of an error, if the first argument is set.
      upgradeError :: Bool -> ExitCode -> Maybe ExitCode -> Maybe ExitCode
upgradeError Bool
False ExitCode
_ Maybe ExitCode
soFar = Maybe ExitCode
soFar
      upgradeError Bool
True ExitCode
exitCode Maybe ExitCode
Nothing = ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just ExitCode
exitCode
      upgradeError Bool
True ExitCode
exitCode (Just ExitCode
ExitSuccess) = ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just ExitCode
exitCode
      upgradeError Bool
True ExitCode
ExitSuccess (Just ExitCode
exitCode) = ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just ExitCode
exitCode
      upgradeError Bool
True (ExitFailure Int
level1) (Just (ExitFailure Int
level2)) =
         ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just (Int -> ExitCode
ExitFailure (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
level1 Int
level2))

foreign import ccall  "default_options.h & default_options"
   defaultOptions :: CString

------------------------------------------------------------------------
-- Printing to stderr.
------------------------------------------------------------------------

printToErr :: String -> IO ()
printToErr :: String -> IO ()
printToErr String
message =
   do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
message