clean up options validation a little

hledger-lib/Hledger/Reports/ReportOptions.hs

@@ -12,6 +12,7 @@ module Hledger.Reports.ReportOptions (
   FormatStr,
   defreportopts,
   rawOptsToReportOpts,
+  checkReportOpts,
   flat_,
   tree_,
   dateSpanFromOpts,
@@ -125,7 +126,7 @@ defreportopts = ReportOpts
     def
 
 rawOptsToReportOpts :: RawOpts -> IO ReportOpts
-rawOptsToReportOpts rawopts = do
+rawOptsToReportOpts rawopts = checkReportOpts <$> do
   d <- getCurrentDay
   return defreportopts{
      begin_       = maybesmartdateopt d "begin" rawopts
@@ -146,7 +147,7 @@ rawOptsToReportOpts rawopts = do
     ,monthly_     = boolopt "monthly" rawopts
     ,quarterly_   = boolopt "quarterly" rawopts
     ,yearly_      = boolopt "yearly" rawopts
-    ,format_      = maybestringopt "format" rawopts
+    ,format_      = maybestringopt "format" rawopts -- XXX move to CliOpts or move validation from Cli.Options to here
     ,query_       = unwords $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right
     ,average_     = boolopt "average" rawopts
     ,related_     = boolopt "related" rawopts
@@ -158,6 +159,11 @@ rawOptsToReportOpts rawopts = do
     ,value_       = boolopt "value" rawopts
     }
 
+-- | Do extra validation of opts, raising an error if there is trouble.
+checkReportOpts :: ReportOpts -> ReportOpts
+checkReportOpts ropts@ReportOpts{..} =
+  ropts
+
 accountlistmodeopt :: RawOpts -> AccountListMode
 accountlistmodeopt rawopts =
   case reverse $ filter (`elem` ["tree","flat"]) $ map fst rawopts of

hledger-ui/Hledger/UI/Options.hs

@@ -59,23 +59,21 @@ defuiopts = UIOpts
 
 -- instance Default CliOpts where def = defcliopts
 
-toUIOpts :: RawOpts -> IO UIOpts
-toUIOpts rawopts = do
+rawOptsToUIOpts :: RawOpts -> IO UIOpts
+rawOptsToUIOpts rawopts = checkUIOpts <$> do
   cliopts <- rawOptsToCliOpts rawopts
   return defuiopts {
               debug_ui_ = boolopt "debug-ui" rawopts
              ,cliopts_   = cliopts
              }
 
-checkUIOpts :: UIOpts -> IO UIOpts
-checkUIOpts opts = do
-  checkCliOpts $ cliopts_ opts
-  case maybestringopt "theme" $ rawopts_ $ cliopts_ opts of
-    Just t | not $ elem t themeNames ->
-      optserror $ "invalid theme name: "++t
-    _ -> return ()
-  return opts
+checkUIOpts :: UIOpts -> UIOpts
+checkUIOpts opts =
+  either optserror (const opts) $ do
+    case maybestringopt "theme" $ rawopts_ $ cliopts_ opts of
+      Just t | not $ elem t themeNames -> Left $ "invalid theme name: "++t
+      _                                -> Right ()
 
 getHledgerUIOpts :: IO UIOpts
-getHledgerUIOpts = processArgs uimode >>= return . decodeRawOpts >>= toUIOpts >>= checkUIOpts
+getHledgerUIOpts = processArgs uimode >>= return . decodeRawOpts >>= rawOptsToUIOpts
 

hledger/Hledger/Cli/Options.hs

@@ -297,7 +297,7 @@ defaultWidth = 80
 -- today's date. Parsing failures will raise an error.
 -- Also records the terminal width, if supported.
 rawOptsToCliOpts :: RawOpts -> IO CliOpts
-rawOptsToCliOpts rawopts = do
+rawOptsToCliOpts rawopts = checkCliOpts <$> do
   ropts <- rawOptsToReportOpts rawopts
   mcolumns <- readMay <$> getEnvSafe "COLUMNS"
   mtermwidth <-
@@ -325,13 +325,14 @@ rawOptsToCliOpts rawopts = do
              }
 
 -- | Do final validation of processed opts, raising an error if there is trouble.
-checkCliOpts :: CliOpts -> IO CliOpts -- or pure..
-checkCliOpts opts@CliOpts{reportopts_=ropts} = do
-  case lineFormatFromOpts ropts of
-    Left err -> optserror $ "could not parse format option: "++err
-    Right _ -> return ()
+checkCliOpts :: CliOpts -> CliOpts
+checkCliOpts opts =
+  either optserror (const opts) $ do
+    -- XXX move to checkReportOpts or move _format to CliOpts
+    case lineFormatFromOpts $ reportopts_ opts of
+      Left err -> Left $ "could not parse format option: "++err
+      Right _  -> Right ()
   -- XXX check registerWidthsFromOpts opts
-  return opts
 
 -- Currently only used by some extras/ scripts:
 -- | Parse hledger CLI options from the command line using the given
@@ -341,7 +342,7 @@ getCliOpts :: Mode RawOpts -> IO CliOpts
 getCliOpts mode' = do
   args' <- getArgs
   let rawopts = decodeRawOpts $ processValue mode' args'
-  opts <- rawOptsToCliOpts rawopts >>= checkCliOpts
+  opts <- rawOptsToCliOpts rawopts
   debugArgs args' opts
   -- if any (`elem` args) ["--help","-h","-?"]
   when ("help" `inRawOpts` rawopts_ opts) $