X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FCommandLine.hs;fp=src%2FCommandLine.hs;h=6479145b2693f6a36e48f53c33db4eb9b836d687;hb=fc0d3c47103269ed75788a87bb5f28ee70408c89;hp=0000000000000000000000000000000000000000;hpb=dba4d4af1a19b54e392f8e41b03e40714c4ac6ab;p=spline3.git

diff --git a/src/CommandLine.hs b/src/CommandLine.hs
new file mode 100644
index 0000000..6479145
--- /dev/null
+++ b/src/CommandLine.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module CommandLine (
+  Args(..),
+  apply_args,
+  program_name,
+  show_help)
+where
+
+-- Get the version from Cabal.
+import Paths_spline3 (version)
+import Data.Version (showVersion)
+
+import Data.String.Utils (startswith)
+import System.Console.CmdArgs (
+  CmdArgs,
+  Data,
+  Mode,
+  Typeable,
+  (&=),
+  argPos,
+  cmdArgsApply,
+  cmdArgsMode,
+  def,
+  details,
+  groupname,
+  help,
+  helpArg,
+  program,
+  typ,
+  summary,
+  versionArg
+  )
+
+import System.Console.CmdArgs.Explicit (process)
+import System.Environment (getArgs, withArgs)
+import System.Exit (ExitCode(..), exitWith)
+import System.IO (hPutStrLn, stderr)
+
+import ExitCodes
+
+
+
+data Args =
+  Args { depth  :: Int,
+         height :: Int,
+         input  :: FilePath,
+         scale  :: Int,
+         slice  :: Maybe Int,
+         output :: FilePath,
+         width  :: Int }
+  deriving   (Show, Data, Typeable)
+
+description :: String
+description =
+  "Interpolate volumetric data according to \"Local quasi-interpolation " ++
+  "by cubic C^1 splines on type-6 tetrahedral partitions.\" The defaults " ++
+  "are tailored to the MRI data contained in data/mri.bin from the " ++
+  "Stanford volume data archive at http://graphics.stanford.edu/data/voldata/."
+
+program_name :: String
+program_name = "spline3"
+
+spline3_summary :: String
+spline3_summary =
+  program_name ++ "-" ++ (showVersion version)
+
+depth_help :: String
+depth_help = "The size of the z dimension (default: 109)"
+
+height_help :: String
+height_help = "The size of the y dimension (default: 256)"
+
+scale_help :: String
+scale_help =
+  "The magnification scale. A scale of 2 would result " ++
+  "in an image twice as large as the original. (default: 2)"
+
+slice_help :: String
+slice_help =
+  "The index of the two-dimensional slice to use if no depth is specified"
+
+width_help :: String
+width_help = "The size of the x dimension (default: 256)"
+
+arg_spec :: Mode (CmdArgs Args)
+arg_spec =
+  cmdArgsMode $
+    Args {
+      depth  = 109     &= groupname "Dimensions" &= help depth_help,
+      height = 256     &= groupname "Dimensions" &= help height_help,
+      input  = def     &= typ "INPUT"            &= argPos 0,
+      output = def     &= typ "OUTPUT"           &= argPos 1,
+      scale  = 2                                 &= help scale_help,
+      slice  = Nothing &= groupname "2D options" &= help slice_help,
+      width  = 256     &= groupname "Dimensions" &= help width_help
+    }
+    &= program program_name
+    &= summary spline3_summary
+    &= details [description]
+    &= helpArg [groupname "Common flags"]
+    &= versionArg [groupname "Common flags"]
+
+-- Infix notation won't work, the arguments are backwards!
+is_missing_arg_error :: String -> Bool
+is_missing_arg_error s =
+  startswith "Requires at least" s
+
+
+show_help :: IO Args
+show_help = withArgs ["--help"] apply_args
+
+parse_args :: IO (CmdArgs Args)
+parse_args = do
+  x <- getArgs
+  let y = process arg_spec x
+  case y of
+      Right result -> return result
+      Left err ->
+        if (is_missing_arg_error err) then
+          -- Start this function over, pretending that --help was
+          -- passed.
+          withArgs ["--help"] parse_args
+        else do
+          hPutStrLn stderr err
+          exitWith (ExitFailure exit_arg_parse_failed)
+
+
+-- | Really get the command-line arguments. This calls 'parse_args'
+--   first to replace the default "wrong number of arguments" error,
+--   and then runs 'cmdArgsApply' on the result to do what the
+--   'cmdArgs' function usually does.
+apply_args :: IO Args
+apply_args =
+  parse_args >>= cmdArgsApply