Rework option parsing to build up a record

I couldn't find a good library to hide the boilerplate :/

1 files changed, 54 insertions, 32 deletions

diff --git a/tt.hs b/tt.hs
index 88755f9..7f1792c 100755
--- a/tt.hs
+++ b/tt.hs
@@ -8,19 +8,58 @@ import System.Directory ( doesFileExist
                         )
 import Data.List (intercalate, stripPrefix, isSuffixOf)
 import Data.Maybe (fromMaybe, listToMaybe)
-import Data.Either (partitionEithers)
 import Control.Applicative ((<$>), (<*>))
 import Control.Monad (when, filterM)
 import System.Environment (getArgs)
 import System.FilePath ((</>))
 import System.Posix.Process (executeFile)
 
-data Command = PrintTestDirectory
-             | RunTests
-
 type Flag = String
-type Option = Either Command Flag
 
+{- Command line argument definitions and parsing -}
+data Options = Options { printTestDirectory :: Bool
+                       , makeFlags :: [Flag]
+                       }
+type OptionTransformer = Options -> Options
+
+defaultOptions :: Options
+defaultOptions = Options { printTestDirectory = False
+                         , makeFlags = []
+                         }
+
+setPrintTestDirectory :: OptionTransformer
+setPrintTestDirectory opts = opts { printTestDirectory = True }
+
+addFlag :: Flag -> OptionTransformer
+addFlag f opts = opts { makeFlags = makeFlags opts ++ [f] }
+
+dialects :: String -> OptionTransformer
+dialects = addFlag . ("JINGLE_DIALECTS=" ++)
+
+simpleOption :: Char -> String -> Flag -> OptDescr OptionTransformer
+simpleOption c s f = Option [c] [s] (NoArg (addFlag f)) ("set " ++ f)
+
+optionDefinitions :: [OptDescr OptionTransformer]
+optionDefinitions =
+    [ simpleOption 'v' "verbose" "CHECK_TWISTED_VERBOSE=1"
+    , simpleOption 'V' "valgrind" "GABBLE_TEST_VALGRIND=1"
+    , Option ['d'] ["dialects"] (ReqArg dialects "DIALECTS")
+             "set JINGLE_DIALECTS to DIALECTS"
+    , Option ['p'] ["print-test-directory"]
+             (NoArg setPrintTestDirectory)
+             "Print the path to the directory containing tests"
+    ]
+
+parseOptions :: [String] -> (Options, [String], [String])
+parseOptions args = (options, tests, errors)
+  where
+    (transformers, tests, errors) = getOpt RequireOrder optionDefinitions args
+    options = foldr (.) id transformers defaultOptions
+
+header :: String
+header = "Usage: tt [-v] [-V] [-d DIALECTS] [tests...]"
+
+{- Building and execution of a `make check-twisted` invocation -}
 runTests :: FilePath -> String -> Bool -> [String] -> [Flag] -> IO ()
 runTests testDir testVar inTree tests flags = do
     let buildPaths = expand testDir inTree . unprefix testDir
@@ -50,25 +89,7 @@ expand testDir inTree s
         (map (s ++) . filter isPython) <$> getDirectoryContents dir
     | otherwise            = return [s ++ ".py"]
 
-dialects :: String -> Option
-dialects = Right . ("JINGLE_DIALECTS=" ++)
-
-simpleOption :: Char -> String -> Flag -> OptDescr Option
-simpleOption c s f = Option [c] [s] (NoArg (Right f)) ("set " ++ f)
-
-options :: [OptDescr Option]
-options = [ simpleOption 'v' "verbose" "CHECK_TWISTED_VERBOSE=1"
-          , simpleOption 'V' "valgrind" "GABBLE_TEST_VALGRIND=1"
-          , Option ['d'] ["dialects"] (ReqArg dialects "DIALECTS")
-                   "set JINGLE_DIALECTS to DIALECTS"
-          , Option ['p'] ["print-test-directory"]
-                   (NoArg (Left PrintTestDirectory))
-                   "Print the path to the directory containing tests"
-          ]
-
-header :: String
-header = "Usage: tt [-v] [-V] [-d DIALECTS] [tests...]"
-
+{- Stupid project-specific crap detection -}
 iFuckingHateMissionControl :: IO (Maybe String)
 iFuckingHateMissionControl = do
     let dirs = [ ("mission-control-plugins", "TWISTED_BASIC_TESTS")
@@ -79,19 +100,20 @@ iFuckingHateMissionControl = do
 
 main :: IO ()
 main = do
-    (commandAndFlags, tests, errors) <- getOpt RequireOrder options <$> getArgs
-    when (not $ null errors) $ do
-        ioError (userError (concat errors ++ usageInfo header options))
+    args <- getArgs
+    let (options, tests, errors) = parseOptions args
 
-    let (commands, flags) = partitionEithers commandAndFlags
+    when (not $ null errors) $ do
+        ioError (userError (concat errors ++
+                            usageInfo header optionDefinitions))
 
     inTree <- doesFileExist "configure"
     iReallyDo <- iFuckingHateMissionControl
 
     case iReallyDo of
         Just testVar -> do
-            case head (commands ++ [RunTests]) of
-                RunTests -> runTests "tests/twisted/" testVar inTree tests flags
-                PrintTestDirectory -> 
-                    putStrLn $ (if inTree then "." else "..") </> "tests/twisted"
+            if printTestDirectory options
+              then putStrLn $ (if inTree then "." else "..") </> "tests/twisted"
+              else runTests "tests/twisted/" testVar inTree tests
+                            (makeFlags options)
         Nothing      -> ioError (userError "no tests here :'(")