;all: hide RawOpts internals

This way we can ensure we always use only functions from RawOptions.
This commit is contained in:
Mykola Orliuk 2019-10-20 01:01:59 +02:00 committed by Simon Michael
parent 8991419c68
commit 5287fe671b
7 changed files with 85 additions and 42 deletions

View File

@ -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 =

View File

@ -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

View File

@ -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) $

View File

@ -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 =

View File

@ -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]")
[]) [])

View File

@ -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

View File

@ -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