;all: hide RawOpts internals
This way we can ensure we always use only functions from RawOptions.
This commit is contained in:
		
							parent
							
								
									8991419c68
								
							
						
					
					
						commit
						5287fe671b
					
				| @ -1,3 +1,5 @@ | |||||||
|  | {-# LANGUAGE DeriveDataTypeable #-} | ||||||
|  | 
 | ||||||
| {-| | {-| | ||||||
| 
 | 
 | ||||||
| hledger's cmdargs modes parse command-line arguments to an | hledger's cmdargs modes parse command-line arguments to an | ||||||
| @ -13,6 +15,8 @@ module Hledger.Data.RawOptions ( | |||||||
|   setboolopt, |   setboolopt, | ||||||
|   inRawOpts, |   inRawOpts, | ||||||
|   boolopt, |   boolopt, | ||||||
|  |   choiceopt, | ||||||
|  |   collectopts, | ||||||
|   stringopt, |   stringopt, | ||||||
|   maybestringopt, |   maybestringopt, | ||||||
|   listofstringopt, |   listofstringopt, | ||||||
| @ -23,38 +27,65 @@ module Hledger.Data.RawOptions ( | |||||||
| where | where | ||||||
| 
 | 
 | ||||||
| import Data.Maybe | import Data.Maybe | ||||||
|  | import Data.Data | ||||||
|  | import Data.Default | ||||||
| import Safe | import Safe | ||||||
| 
 | 
 | ||||||
| import Hledger.Utils | import Hledger.Utils | ||||||
| 
 | 
 | ||||||
| 
 | 
 | ||||||
| -- | The result of running cmdargs: an association list of option names to string values. | -- | The result of running cmdargs: an association list of option names to string values. | ||||||
| type RawOpts = [(String,String)] | newtype RawOpts = RawOpts { unRawOpts :: [(String,String)] } | ||||||
|  |     deriving (Show, Data, Typeable) | ||||||
|  | 
 | ||||||
|  | instance Default RawOpts where def = RawOpts [] | ||||||
|  | 
 | ||||||
|  | overRawOpts f = RawOpts . f . unRawOpts | ||||||
| 
 | 
 | ||||||
| setopt :: String -> String -> RawOpts -> RawOpts | setopt :: String -> String -> RawOpts -> RawOpts | ||||||
| setopt name val = (++ [(name, val)]) | setopt name val = overRawOpts (++ [(name, val)]) | ||||||
| 
 | 
 | ||||||
| setboolopt :: String -> RawOpts -> RawOpts | setboolopt :: String -> RawOpts -> RawOpts | ||||||
| setboolopt name = (++ [(name,"")]) | setboolopt name = overRawOpts (++ [(name,"")]) | ||||||
| 
 | 
 | ||||||
| -- | Is the named option present ? | -- | Is the named option present ? | ||||||
| inRawOpts :: String -> RawOpts -> Bool | inRawOpts :: String -> RawOpts -> Bool | ||||||
| inRawOpts name = isJust . lookup name | inRawOpts name = isJust . lookup name . unRawOpts | ||||||
| 
 | 
 | ||||||
| boolopt :: String -> RawOpts -> Bool | boolopt :: String -> RawOpts -> Bool | ||||||
| boolopt = inRawOpts | boolopt = inRawOpts | ||||||
| 
 | 
 | ||||||
|  | -- | Get latests successfully parsed flag | ||||||
|  | -- | ||||||
|  | -- >>> choiceopt Just (RawOpts [("a",""), ("b",""), ("c","")]) | ||||||
|  | -- Just "c" | ||||||
|  | -- >>> choiceopt (const Nothing) (RawOpts [("a","")]) | ||||||
|  | -- Nothing | ||||||
|  | -- >>> choiceopt (listToMaybe . filter (`elem` ["a","b"])) (RawOpts [("a",""), ("b",""), ("c","")]) | ||||||
|  | -- Just "b" | ||||||
|  | choiceopt :: (String -> Maybe a) -> RawOpts -> Maybe a | ||||||
|  | choiceopt f = lastMay . collectopts (f . fst) | ||||||
|  | 
 | ||||||
|  | -- | Collects processed and filtered list of options preserving their order | ||||||
|  | -- | ||||||
|  | -- >>> collectopts (const Nothing) (RawOpts [("x","")]) | ||||||
|  | -- [] | ||||||
|  | -- >>> collectopts Just (RawOpts [("a",""),("b","")]) | ||||||
|  | -- [("a",""),("b","")] | ||||||
|  | collectopts :: ((String, String) -> Maybe a) -> RawOpts -> [a] | ||||||
|  | collectopts f = mapMaybe f . unRawOpts | ||||||
|  | 
 | ||||||
| maybestringopt :: String -> RawOpts -> Maybe String | maybestringopt :: String -> RawOpts -> Maybe String | ||||||
| maybestringopt name = lookup name . reverse | maybestringopt name = lookup name . reverse . unRawOpts | ||||||
| 
 | 
 | ||||||
| stringopt :: String -> RawOpts -> String | stringopt :: String -> RawOpts -> String | ||||||
| stringopt name = fromMaybe "" . maybestringopt name | stringopt name = fromMaybe "" . maybestringopt name | ||||||
| 
 | 
 | ||||||
| maybecharopt :: String -> RawOpts -> Maybe Char | maybecharopt :: String -> RawOpts -> Maybe Char | ||||||
| maybecharopt name rawopts = lookup name rawopts >>= headMay | maybecharopt name (RawOpts rawopts) = lookup name rawopts >>= headMay | ||||||
| 
 | 
 | ||||||
| listofstringopt :: String -> RawOpts -> [String] | listofstringopt :: String -> RawOpts -> [String] | ||||||
| listofstringopt name rawopts = [v | (k,v) <- rawopts, k==name] | listofstringopt name (RawOpts rawopts) = [v | (k,v) <- rawopts, k==name] | ||||||
| 
 | 
 | ||||||
| maybeintopt :: String -> RawOpts -> Maybe Int | maybeintopt :: String -> RawOpts -> Maybe Int | ||||||
| maybeintopt name rawopts = | maybeintopt name rawopts = | ||||||
|  | |||||||
| @ -4,7 +4,7 @@ Options common to most hledger reports. | |||||||
| 
 | 
 | ||||||
| -} | -} | ||||||
| 
 | 
 | ||||||
| {-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable #-} | {-# LANGUAGE OverloadedStrings, RecordWildCards, LambdaCase, DeriveDataTypeable #-} | ||||||
| 
 | 
 | ||||||
| module Hledger.Reports.ReportOptions ( | module Hledger.Reports.ReportOptions ( | ||||||
|   ReportOpts(..), |   ReportOpts(..), | ||||||
| @ -220,18 +220,20 @@ checkReportOpts ropts@ReportOpts{..} = | |||||||
|       _              -> Right () |       _              -> Right () | ||||||
| 
 | 
 | ||||||
| accountlistmodeopt :: RawOpts -> AccountListMode | accountlistmodeopt :: RawOpts -> AccountListMode | ||||||
| accountlistmodeopt rawopts = | accountlistmodeopt = | ||||||
|   case reverse $ filter (`elem` ["tree","flat"]) $ map fst rawopts of |   fromMaybe ALDefault . choiceopt parse where | ||||||
|     ("tree":_) -> ALTree |     parse = \case | ||||||
|     ("flat":_) -> ALFlat |       "tree" -> Just ALTree | ||||||
|     _          -> ALDefault |       "flat" -> Just ALFlat | ||||||
|  |       _      -> Nothing | ||||||
| 
 | 
 | ||||||
| balancetypeopt :: RawOpts -> BalanceType | balancetypeopt :: RawOpts -> BalanceType | ||||||
| balancetypeopt rawopts = | balancetypeopt = | ||||||
|   case reverse $ filter (`elem` ["change","cumulative","historical"]) $ map fst rawopts of |   fromMaybe PeriodChange . choiceopt parse where | ||||||
|     ("historical":_) -> HistoricalBalance |     parse = \case | ||||||
|     ("cumulative":_) -> CumulativeChange |       "historical" -> Just HistoricalBalance | ||||||
|     _                -> PeriodChange |       "cumulative" -> Just CumulativeChange | ||||||
|  |       _            -> Nothing | ||||||
| 
 | 
 | ||||||
| -- Get the period specified by any -b/--begin, -e/--end and/or -p/--period | -- Get the period specified by any -b/--begin, -e/--end and/or -p/--period | ||||||
| -- options appearing in the command line. | -- options appearing in the command line. | ||||||
| @ -257,7 +259,7 @@ periodFromRawOpts d rawopts = | |||||||
| -- Get all begin dates specified by -b/--begin or -p/--period options, in order, | -- Get all begin dates specified by -b/--begin or -p/--period options, in order, | ||||||
| -- using the given date to interpret relative date expressions. | -- using the given date to interpret relative date expressions. | ||||||
| beginDatesFromRawOpts :: Day -> RawOpts -> [Day] | beginDatesFromRawOpts :: Day -> RawOpts -> [Day] | ||||||
| beginDatesFromRawOpts d = catMaybes . map (begindatefromrawopt d) | beginDatesFromRawOpts d = collectopts (begindatefromrawopt d) | ||||||
|   where |   where | ||||||
|     begindatefromrawopt d (n,v) |     begindatefromrawopt d (n,v) | ||||||
|       | n == "begin" = |       | n == "begin" = | ||||||
| @ -275,7 +277,7 @@ beginDatesFromRawOpts d = catMaybes . map (begindatefromrawopt d) | |||||||
| -- Get all end dates specified by -e/--end or -p/--period options, in order, | -- Get all end dates specified by -e/--end or -p/--period options, in order, | ||||||
| -- using the given date to interpret relative date expressions. | -- using the given date to interpret relative date expressions. | ||||||
| endDatesFromRawOpts :: Day -> RawOpts -> [Day] | endDatesFromRawOpts :: Day -> RawOpts -> [Day] | ||||||
| endDatesFromRawOpts d = catMaybes . map (enddatefromrawopt d) | endDatesFromRawOpts d = collectopts (enddatefromrawopt d) | ||||||
|   where |   where | ||||||
|     enddatefromrawopt d (n,v) |     enddatefromrawopt d (n,v) | ||||||
|       | n == "end" = |       | n == "end" = | ||||||
| @ -294,7 +296,7 @@ endDatesFromRawOpts d = catMaybes . map (enddatefromrawopt d) | |||||||
| -- -D/--daily, -W/--weekly, -M/--monthly etc. options. | -- -D/--daily, -W/--weekly, -M/--monthly etc. options. | ||||||
| -- An interval from --period counts only if it is explicitly defined. | -- An interval from --period counts only if it is explicitly defined. | ||||||
| intervalFromRawOpts :: RawOpts -> Interval | intervalFromRawOpts :: RawOpts -> Interval | ||||||
| intervalFromRawOpts = lastDef NoInterval . catMaybes . map intervalfromrawopt | intervalFromRawOpts = lastDef NoInterval . collectopts intervalfromrawopt | ||||||
|   where |   where | ||||||
|     intervalfromrawopt (n,v) |     intervalfromrawopt (n,v) | ||||||
|       | n == "period" = |       | n == "period" = | ||||||
| @ -321,7 +323,7 @@ extractIntervalOrNothing (interval, _) = Just interval | |||||||
| -- -P/--pending, -C/--cleared flags. -UPC is equivalent to no flags, | -- -P/--pending, -C/--cleared flags. -UPC is equivalent to no flags, | ||||||
| -- so this returns a list of 0-2 unique statuses. | -- so this returns a list of 0-2 unique statuses. | ||||||
| statusesFromRawOpts :: RawOpts -> [Status] | statusesFromRawOpts :: RawOpts -> [Status] | ||||||
| statusesFromRawOpts = simplifyStatuses . catMaybes . map statusfromrawopt | statusesFromRawOpts = simplifyStatuses . collectopts statusfromrawopt | ||||||
|   where |   where | ||||||
|     statusfromrawopt (n,_) |     statusfromrawopt (n,_) | ||||||
|       | n == "unmarked"  = Just Unmarked |       | n == "unmarked"  = Just Unmarked | ||||||
| @ -347,7 +349,7 @@ reportOptsToggleStatus s ropts@ReportOpts{statuses_=ss} | |||||||
| -- -B/--cost, -V, -X/--exchange, or --value flags. If there's more | -- -B/--cost, -V, -X/--exchange, or --value flags. If there's more | ||||||
| -- than one of these, the rightmost flag wins. | -- than one of these, the rightmost flag wins. | ||||||
| valuationTypeFromRawOpts :: RawOpts -> Maybe ValuationType | valuationTypeFromRawOpts :: RawOpts -> Maybe ValuationType | ||||||
| valuationTypeFromRawOpts = lastDef Nothing . filter isJust . map valuationfromrawopt | valuationTypeFromRawOpts = lastMay . collectopts valuationfromrawopt | ||||||
|   where |   where | ||||||
|     valuationfromrawopt (n,v)  -- option name, value |     valuationfromrawopt (n,v)  -- option name, value | ||||||
|       | n == "B"     = Just $ AtCost Nothing |       | n == "B"     = Just $ AtCost Nothing | ||||||
|  | |||||||
| @ -4,6 +4,7 @@ Copyright (c) 2007-2015 Simon Michael <simon@joyful.com> | |||||||
| Released under GPL version 3 or later. | Released under GPL version 3 or later. | ||||||
| -} | -} | ||||||
| {-# LANGUAGE CPP #-} | {-# LANGUAGE CPP #-} | ||||||
|  | {-# LANGUAGE LambdaCase #-} | ||||||
| {-# LANGUAGE OverloadedStrings #-} | {-# LANGUAGE OverloadedStrings #-} | ||||||
| {-# LANGUAGE MultiParamTypeClasses #-} | {-# LANGUAGE MultiParamTypeClasses #-} | ||||||
| 
 | 
 | ||||||
| @ -97,7 +98,7 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{inputopts_=_iopts,reportopts_=rop | |||||||
|             depth_ =depthfromoptsandargs, |             depth_ =depthfromoptsandargs, | ||||||
|             period_=periodfromoptsandargs, |             period_=periodfromoptsandargs, | ||||||
|             query_ =unwords -- as in ReportOptions, with same limitations |             query_ =unwords -- as in ReportOptions, with same limitations | ||||||
|                     [quoteIfNeeded v | (k,v) <- rawopts_ copts, k=="args", not $ any (`isPrefixOf` v) ["depth","date"]], |                     $ collectopts filteredQueryArg (rawopts_ copts), | ||||||
|             -- always disable boring account name eliding, unlike the CLI, for a more regular tree |             -- always disable boring account name eliding, unlike the CLI, for a more regular tree | ||||||
|             no_elide_=True, |             no_elide_=True, | ||||||
|             -- flip the default for items with zero amounts, show them by default |             -- flip the default for items with zero amounts, show them by default | ||||||
| @ -114,6 +115,11 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{inputopts_=_iopts,reportopts_=rop | |||||||
|         datespanfromargs = queryDateSpan (date2_ ropts) $ fst $ parseQuery d (T.pack $ query_ ropts) |         datespanfromargs = queryDateSpan (date2_ ropts) $ fst $ parseQuery d (T.pack $ query_ ropts) | ||||||
|         periodfromoptsandargs = |         periodfromoptsandargs = | ||||||
|           dateSpanAsPeriod $ spansIntersect [periodAsDateSpan $ period_ ropts, datespanfromargs] |           dateSpanAsPeriod $ spansIntersect [periodAsDateSpan $ period_ ropts, datespanfromargs] | ||||||
|  |         filteredQueryArg = \case | ||||||
|  |             ("args", v) | ||||||
|  |                 | not $ any (`isPrefixOf` v) ["depth:", "date:"] -- skip depth/date passed as query | ||||||
|  |                     -> Just (quoteIfNeeded v) | ||||||
|  |             _ -> Nothing | ||||||
| 
 | 
 | ||||||
|     -- XXX move this stuff into Options, UIOpts |     -- XXX move this stuff into Options, UIOpts | ||||||
|     theme = maybe defaultTheme (fromMaybe defaultTheme . getTheme) $ |     theme = maybe defaultTheme (fromMaybe defaultTheme . getTheme) $ | ||||||
|  | |||||||
| @ -1,5 +1,6 @@ | |||||||
| {-# LANGUAGE CPP #-} | {-# LANGUAGE CPP #-} | ||||||
| {-# LANGUAGE DeriveDataTypeable #-} | {-# LANGUAGE DeriveDataTypeable #-} | ||||||
|  | {-# LANGUAGE LambdaCase #-} | ||||||
| {-| | {-| | ||||||
| 
 | 
 | ||||||
| -} | -} | ||||||
| @ -10,6 +11,7 @@ import Data.Data (Data) | |||||||
| import Data.Default | import Data.Default | ||||||
| import Data.Typeable (Typeable) | import Data.Typeable (Typeable) | ||||||
| import Data.List (intercalate) | import Data.List (intercalate) | ||||||
|  | import Data.Maybe (fromMaybe) | ||||||
| import System.Environment | import System.Environment | ||||||
| 
 | 
 | ||||||
| import Hledger.Cli hiding (progname,version,prognameandversion) | import Hledger.Cli hiding (progname,version,prognameandversion) | ||||||
| @ -45,8 +47,8 @@ uiflags = [ | |||||||
|   -- ,flagNone ["no-elide"] (setboolopt "no-elide") "don't compress empty parent accounts on one line" |   -- ,flagNone ["no-elide"] (setboolopt "no-elide") "don't compress empty parent accounts on one line" | ||||||
|  ] |  ] | ||||||
| 
 | 
 | ||||||
| --uimode :: Mode [([Char], [Char])] | --uimode :: Mode RawOpts | ||||||
| uimode =  (mode "hledger-ui" [("command","ui")] | uimode =  (mode "hledger-ui" (setopt "command" "ui" def) | ||||||
|             "browse accounts, postings and entries in a full-window curses interface" |             "browse accounts, postings and entries in a full-window curses interface" | ||||||
|             (argsFlag "[PATTERNS]") []){ |             (argsFlag "[PATTERNS]") []){ | ||||||
|               modeGroupFlags = Group { |               modeGroupFlags = Group { | ||||||
| @ -91,11 +93,12 @@ data PresentOrFutureOpt = PFDefault | PFPresent | PFFuture deriving (Eq, Show, D | |||||||
| instance Default PresentOrFutureOpt where def = PFDefault | instance Default PresentOrFutureOpt where def = PFDefault | ||||||
| 
 | 
 | ||||||
| presentorfutureopt :: RawOpts -> PresentOrFutureOpt | presentorfutureopt :: RawOpts -> PresentOrFutureOpt | ||||||
| presentorfutureopt rawopts = | presentorfutureopt = | ||||||
|   case reverse $ filter (`elem` ["present","future"]) $ map fst rawopts of |   fromMaybe PFDefault . choiceopt parse where | ||||||
|     ("present":_) -> PFPresent |     parse = \case | ||||||
|     ("future":_)  -> PFFuture |       "present" -> Just PFPresent | ||||||
|     _             -> PFDefault |       "future"  -> Just PFFuture | ||||||
|  |       _         -> Nothing | ||||||
| 
 | 
 | ||||||
| checkUIOpts :: UIOpts -> UIOpts | checkUIOpts :: UIOpts -> UIOpts | ||||||
| checkUIOpts opts = | checkUIOpts opts = | ||||||
|  | |||||||
| @ -28,7 +28,7 @@ version = "" | |||||||
| prognameandversion :: String | prognameandversion :: String | ||||||
| prognameandversion = progname ++ " " ++ version :: String | prognameandversion = progname ++ " " ++ version :: String | ||||||
| 
 | 
 | ||||||
| webflags :: [Flag [(String, String)]] | webflags :: [Flag RawOpts] | ||||||
| webflags = | webflags = | ||||||
|   [ flagNone |   [ flagNone | ||||||
|       ["serve", "server"] |       ["serve", "server"] | ||||||
| @ -75,11 +75,11 @@ webflags = | |||||||
|       "read capabilities to enable from a HTTP header, like X-Sandstorm-Permissions (default: disabled)" |       "read capabilities to enable from a HTTP header, like X-Sandstorm-Permissions (default: disabled)" | ||||||
|   ] |   ] | ||||||
| 
 | 
 | ||||||
| webmode :: Mode [(String, String)] | webmode :: Mode RawOpts | ||||||
| webmode = | webmode = | ||||||
|   (mode |   (mode | ||||||
|      "hledger-web" |      "hledger-web" | ||||||
|      [("command", "web")] |      (setopt "command" "web" def) | ||||||
|      "start serving the hledger web interface" |      "start serving the hledger web interface" | ||||||
|      (argsFlag "[PATTERNS]") |      (argsFlag "[PATTERNS]") | ||||||
|      []) |      []) | ||||||
|  | |||||||
| @ -223,7 +223,7 @@ defMode = Mode { | |||||||
|    ,groupHidden  = []             --  flags not displayed in the usage |    ,groupHidden  = []             --  flags not displayed in the usage | ||||||
|    } |    } | ||||||
|  ,modeArgs        = ([], Nothing) -- description of arguments accepted by the command |  ,modeArgs        = ([], Nothing) -- description of arguments accepted by the command | ||||||
|  ,modeValue       = []            -- value returned when this mode is used to parse a command line |  ,modeValue       = def           -- value returned when this mode is used to parse a command line | ||||||
|  ,modeCheck       = Right         -- whether the mode's value is correct |  ,modeCheck       = Right         -- whether the mode's value is correct | ||||||
|  ,modeReform      = const Nothing -- function to convert the value back to a command line arguments |  ,modeReform      = const Nothing -- function to convert the value back to a command line arguments | ||||||
|  ,modeExpandAt    = True          -- expand @ arguments for program ? |  ,modeExpandAt    = True          -- expand @ arguments for program ? | ||||||
| @ -245,7 +245,7 @@ defCommandMode names = defMode { | |||||||
|     ,groupHidden  = []             --  flags not displayed in the usage |     ,groupHidden  = []             --  flags not displayed in the usage | ||||||
|     } |     } | ||||||
|   ,modeArgs = ([], Just $ argsFlag "[QUERY]") |   ,modeArgs = ([], Just $ argsFlag "[QUERY]") | ||||||
|   ,modeValue=[("command", headDef "" names)] |   ,modeValue=setopt "command" (headDef "" names) def | ||||||
|   } |   } | ||||||
| 
 | 
 | ||||||
| -- | A cmdargs mode representing the hledger add-on command with the | -- | A cmdargs mode representing the hledger add-on command with the | ||||||
|  | |||||||
| @ -1,4 +1,4 @@ | |||||||
| {-# LANGUAGE OverloadedStrings, RecordWildCards #-} | {-# LANGUAGE OverloadedStrings, RecordWildCards, LambdaCase #-} | ||||||
| {-| | {-| | ||||||
| 
 | 
 | ||||||
| Common helpers for making multi-section balance report commands | Common helpers for making multi-section balance report commands | ||||||
| @ -125,11 +125,12 @@ compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportopts_=r | |||||||
|     let |     let | ||||||
|       -- use the default balance type for this report, unless the user overrides |       -- use the default balance type for this report, unless the user overrides | ||||||
|       mBalanceTypeOverride = |       mBalanceTypeOverride = | ||||||
|         case reverse $ filter (`elem` ["change","cumulative","historical"]) $ map fst rawopts of |         choiceopt parse rawopts where | ||||||
|           "historical":_ -> Just HistoricalBalance |           parse = \case | ||||||
|           "cumulative":_ -> Just CumulativeChange |             "historical" -> Just HistoricalBalance | ||||||
|           "change":_     -> Just PeriodChange |             "cumulative" -> Just CumulativeChange | ||||||
|           _              -> Nothing |             "change"     -> Just PeriodChange | ||||||
|  |             _            -> Nothing | ||||||
|       balancetype = fromMaybe cbctype mBalanceTypeOverride |       balancetype = fromMaybe cbctype mBalanceTypeOverride | ||||||
|       -- Set balance type in the report options. |       -- Set balance type in the report options. | ||||||
|       -- Also, use tree mode (by default, at least?) if --cumulative/--historical |       -- Also, use tree mode (by default, at least?) if --cumulative/--historical | ||||||
|  | |||||||
		Loading…
	
		Reference in New Issue
	
	Block a user