lib, cli, ui, web: intopt and friends now make sure their arguments fit

inside bounds.

hledger-lib/Hledger/Data/RawOptions.hs

@@ -21,7 +21,9 @@ module Hledger.Data.RawOptions (
   maybestringopt,
   listofstringopt,
   intopt,
+  posintopt,
   maybeintopt,
+  maybeposintopt,
   maybecharopt
 )
 where
@@ -91,12 +93,35 @@ maybecharopt name (RawOpts rawopts) = lookup name rawopts >>= headMay
 listofstringopt :: String -> RawOpts -> [String]
 listofstringopt name (RawOpts rawopts) = [v | (k,v) <- rawopts, k==name]
 
+-- | Reads the named option's Int argument, if it is present.
+-- An argument that is too small or too large will raise an error.
 maybeintopt :: String -> RawOpts -> Maybe Int
-maybeintopt name rawopts =
-    let ms = maybestringopt name rawopts in
-    case ms of Nothing -> Nothing
-               Just s -> Just $ readDef (usageError $ "could not parse "++name++" number: "++s) s
+maybeintopt = maybeclippedintopt minBound maxBound
 
+-- | Reads the named option's natural-number argument, if it is present.
+-- An argument that is negative or too large will raise an error.
+maybeposintopt :: String -> RawOpts -> Maybe Int
+maybeposintopt = maybeclippedintopt 0 maxBound
+
+-- | Reads the named option's Int argument. If not present it will
+-- return 0. An argument that is too small or too large will raise an error.
 intopt :: String -> RawOpts -> Int
 intopt name = fromMaybe 0 . maybeintopt name
 
+-- | Reads the named option's natural-number argument. If not present it will
+-- return 0. An argument that is negative or too large will raise an error.
+posintopt :: String -> RawOpts -> Int
+posintopt name = fromMaybe 0 . maybeposintopt name
+
+-- | Reads the named option's Int argument, if it is present. An argument
+-- that does not fit within the given bounds will raise an error.
+maybeclippedintopt :: Int -> Int -> String -> RawOpts -> Maybe Int
+maybeclippedintopt minVal maxVal name =
+    fmap (intOrError . readOrError) . maybestringopt name
+  where
+    readOrError s = readDef (usageError $ "could not parse " ++ name ++ " number: " ++ s) s
+    intOrError n | n >= toInteger minVal && n <= toInteger maxVal = fromInteger n
+                 | otherwise = usageError $ "argument to " ++ name
+                                         ++ " must lie in the range "
+                                         ++ show minVal ++ " to " ++ show maxVal
+                                         ++ ", but is " ++ show n

hledger-lib/Hledger/Reports/MultiBalanceReport.hs

@@ -434,13 +434,13 @@ displayedAccounts ropts q valuedaccts
 
     displayedName name
         | flat_ ropts = DisplayName name droppedName 1
-        | otherwise   = DisplayName name leaf $ level - boringParents
+        | otherwise   = DisplayName name leaf . max 0 $ level - boringParents
       where
         droppedName = accountNameDrop (drop_ ropts) name
         leaf = accountNameFromComponents . reverse . map accountLeafName $
             droppedName : takeWhile notDisplayed parents
 
-        level = accountNameLevel name - drop_ ropts
+        level = max 0 $ accountNameLevel name - drop_ ropts
         parents = take (level - 1) $ parentAccountNames name
         boringParents = if no_elide_ ropts then 0 else length $ filter notDisplayed parents
         notDisplayed = not . (`HM.member` displayedAccts)

hledger-lib/Hledger/Reports/ReportOptions.hs

@@ -176,7 +176,7 @@ rawOptsToReportOpts rawopts = checkReportOpts <$> do
     ,statuses_    = statusesFromRawOpts rawopts'
     ,value_       = valuationTypeFromRawOpts rawopts'
     ,infer_value_ = boolopt "infer-value" rawopts'
-    ,depth_       = maybeintopt "depth" rawopts'
+    ,depth_       = maybeposintopt "depth" rawopts'
     ,display_     = maybedisplayopt d rawopts'
     ,date2_       = boolopt "date2" rawopts'
     ,empty_       = boolopt "empty" rawopts'
@@ -188,7 +188,7 @@ rawOptsToReportOpts rawopts = checkReportOpts <$> do
     ,related_     = boolopt "related" rawopts'
     ,balancetype_ = balancetypeopt rawopts'
     ,accountlistmode_ = accountlistmodeopt rawopts'
-    ,drop_        = intopt "drop" rawopts'
+    ,drop_        = posintopt "drop" rawopts'
     ,row_total_   = boolopt "row-total" rawopts'
     ,no_total_    = boolopt "no-total" rawopts'
     ,sort_amount_ = boolopt "sort-amount" rawopts'

hledger-ui/Hledger/UI/UIState.hs

@@ -49,14 +49,14 @@ uiShowStatus copts ss =
     _ -> map showstatus $ sort ss
   where
     numstatuses = length [minBound..maxBound::Status]
-    style = maybeintopt "status-toggles" $ rawopts_ copts
+    style = maybeposintopt "status-toggles" $ rawopts_ copts
     showstatus Cleared  = "cleared"
     showstatus Pending  = "pending"
     showstatus Unmarked = "unmarked"
 
 reportOptsToggleStatusSomehow :: Status -> CliOpts -> ReportOpts -> ReportOpts
 reportOptsToggleStatusSomehow s copts ropts =
-  case maybeintopt "status-toggles" $ rawopts_ copts of
+  case maybeposintopt "status-toggles" $ rawopts_ copts of
      Just 2 -> reportOptsToggleStatus2 s ropts
      Just 3 -> reportOptsToggleStatus3 s ropts
 --     Just 4 -> reportOptsToggleStatus4 s ropts

hledger-web/Hledger/Web/WebOptions.hs

@@ -128,7 +128,7 @@ rawOptsToWebOpts rawopts =
   checkWebOpts <$> do
     cliopts <- rawOptsToCliOpts rawopts
     let h = fromMaybe defhost $ maybestringopt "host" rawopts
-        p = fromMaybe defport $ maybeintopt "port" rawopts
+        p = fromMaybe defport $ maybeposintopt "port" rawopts
         b =
           maybe (defbaseurl h p) stripTrailingSlash $
           maybestringopt "base-url" rawopts

hledger/Hledger/Cli/CliOptions.hs

@@ -446,7 +446,7 @@ rawOptsToCliOpts rawopts = checkCliOpts <$> do
              ,reportopts_      = ropts
              ,output_file_     = maybestringopt "output-file" rawopts
              ,output_format_   = maybestringopt "output-format" rawopts
-             ,debug_           = intopt "debug" rawopts
+             ,debug_           = posintopt "debug" rawopts
              ,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add
              ,width_           = maybestringopt "width" rawopts
              ,available_width_ = availablewidth