{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

module Hledger.UI.UIOptions where

import Data.Default (def)
import Data.Either (fromRight)
import Data.List (intercalate)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import GitHash (tGitInfoCwdTry)
import Lens.Micro (set)
import System.Environment (getArgs)

import Hledger.Cli hiding (packageversion, progname, prognameandversion)
import Hledger.UI.Theme (themes, themeNames)

-- cf Hledger.Cli.Version

packageversion :: PackageVersionString
packageversion :: PackageVersionString
packageversion =
#ifdef VERSION
  VERSION
#else
  ""
#endif

progname :: ProgramName
progname :: PackageVersionString
progname = PackageVersionString
"hledger-ui"

-- | Generate the version string for this program.
-- The template haskell call is here rather than in Hledger.Cli.Version to avoid wasteful recompilation.
prognameandversion :: String
prognameandversion :: PackageVersionString
prognameandversion =
  Either PackageVersionString GitInfo
-> Bool
-> PackageVersionString
-> PackageVersionString
-> PackageVersionString
versionStringWith
  $$PackageVersionString
PackageVersionString -> Either PackageVersionString GitInfo
forall a b. a -> Either a b
tGitInfoCwdTry
#ifdef GHCDEBUG
  True
#else
  Bool
False
#endif
  PackageVersionString
progname
  PackageVersionString
packageversion

binaryinfo :: HledgerBinaryInfo
binaryinfo :: HledgerBinaryInfo
binaryinfo = HledgerBinaryInfo
-> Either PackageVersionString HledgerBinaryInfo
-> HledgerBinaryInfo
forall b a. b -> Either a b -> b
fromRight HledgerBinaryInfo
nullbinaryinfo (Either PackageVersionString HledgerBinaryInfo
 -> HledgerBinaryInfo)
-> Either PackageVersionString HledgerBinaryInfo
-> HledgerBinaryInfo
forall a b. (a -> b) -> a -> b
$ PackageVersionString
-> Either PackageVersionString HledgerBinaryInfo
parseHledgerVersion PackageVersionString
prognameandversion


uiflags :: [Flag RawOpts]
uiflags = [
   [PackageVersionString]
-> (RawOpts -> RawOpts) -> PackageVersionString -> Flag RawOpts
forall a.
[PackageVersionString]
-> (a -> a) -> PackageVersionString -> Flag a
flagNone [PackageVersionString
"watch",PackageVersionString
"w"] (PackageVersionString -> RawOpts -> RawOpts
setboolopt PackageVersionString
"watch") PackageVersionString
"watch for data and date changes and reload automatically"
  ,[PackageVersionString]
-> Update RawOpts
-> PackageVersionString
-> PackageVersionString
-> Flag RawOpts
forall a.
[PackageVersionString]
-> Update a
-> PackageVersionString
-> PackageVersionString
-> Flag a
flagReq  [PackageVersionString
"theme"] (\PackageVersionString
s RawOpts
opts -> RawOpts -> Either PackageVersionString RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either PackageVersionString RawOpts)
-> RawOpts -> Either PackageVersionString RawOpts
forall a b. (a -> b) -> a -> b
$ PackageVersionString -> PackageVersionString -> RawOpts -> RawOpts
setopt PackageVersionString
"theme" PackageVersionString
s RawOpts
opts) PackageVersionString
"THEME" (PackageVersionString
"use this custom display theme ("PackageVersionString
-> PackageVersionString -> PackageVersionString
forall a. [a] -> [a] -> [a]
++PackageVersionString
-> [PackageVersionString] -> PackageVersionString
forall a. [a] -> [[a]] -> [a]
intercalate PackageVersionString
", " [PackageVersionString]
themeNamesPackageVersionString
-> PackageVersionString -> PackageVersionString
forall a. [a] -> [a] -> [a]
++PackageVersionString
")")
  ,[PackageVersionString]
-> (RawOpts -> RawOpts) -> PackageVersionString -> Flag RawOpts
forall a.
[PackageVersionString]
-> (a -> a) -> PackageVersionString -> Flag a
flagNone [PackageVersionString
"cash"] (PackageVersionString -> RawOpts -> RawOpts
setboolopt PackageVersionString
"cash") PackageVersionString
"start in: the cash accounts screen"
  ,[PackageVersionString]
-> (RawOpts -> RawOpts) -> PackageVersionString -> Flag RawOpts
forall a.
[PackageVersionString]
-> (a -> a) -> PackageVersionString -> Flag a
flagNone [PackageVersionString
"bs"] (PackageVersionString -> RawOpts -> RawOpts
setboolopt PackageVersionString
"bs") PackageVersionString
"start in: the balance sheet accounts screen"
  ,[PackageVersionString]
-> (RawOpts -> RawOpts) -> PackageVersionString -> Flag RawOpts
forall a.
[PackageVersionString]
-> (a -> a) -> PackageVersionString -> Flag a
flagNone [PackageVersionString
"is"] (PackageVersionString -> RawOpts -> RawOpts
setboolopt PackageVersionString
"is") PackageVersionString
"start in: the income statement accounts screen"
  ,[PackageVersionString]
-> (RawOpts -> RawOpts) -> PackageVersionString -> Flag RawOpts
forall a.
[PackageVersionString]
-> (a -> a) -> PackageVersionString -> Flag a
flagNone [PackageVersionString
"all"] (PackageVersionString -> RawOpts -> RawOpts
setboolopt PackageVersionString
"all") PackageVersionString
"start in: the all accounts screen"
  ,[PackageVersionString]
-> Update RawOpts
-> PackageVersionString
-> PackageVersionString
-> Flag RawOpts
forall a.
[PackageVersionString]
-> Update a
-> PackageVersionString
-> PackageVersionString
-> Flag a
flagReq  [PackageVersionString
"register"] (\PackageVersionString
s RawOpts
opts -> RawOpts -> Either PackageVersionString RawOpts
forall a b. b -> Either a b
Right (RawOpts -> Either PackageVersionString RawOpts)
-> RawOpts -> Either PackageVersionString RawOpts
forall a b. (a -> b) -> a -> b
$ PackageVersionString -> PackageVersionString -> RawOpts -> RawOpts
setopt PackageVersionString
"register" PackageVersionString
s RawOpts
opts) PackageVersionString
"ACCTREGEX" PackageVersionString
"start in: the (first matched) account's register"
  ,[PackageVersionString]
-> (RawOpts -> RawOpts) -> PackageVersionString -> Flag RawOpts
forall a.
[PackageVersionString]
-> (a -> a) -> PackageVersionString -> Flag a
flagNone [PackageVersionString
"change"] (PackageVersionString -> RawOpts -> RawOpts
setboolopt PackageVersionString
"change")
    PackageVersionString
"show period balances (changes) at startup instead of historical balances"
  -- ,flagNone ["cumulative"] (setboolopt "cumulative")
  --   "show balance change accumulated across periods (in multicolumn reports)"
  -- ,flagNone ["historical","H"] (setboolopt "historical")
  --   "show historical ending balance in each period (includes postings before report start date)\n "
  ]
  [Flag RawOpts] -> [Flag RawOpts] -> [Flag RawOpts]
forall a. [a] -> [a] -> [a]
++ Bool -> [Flag RawOpts]
flattreeflags Bool
False
--  ,flagNone ["present"] (setboolopt "present") "exclude transactions dated later than today (default)"
  -- ,flagReq ["drop"] (\s opts -> Right $ setopt "drop" s opts) "N" "with --flat, omit this many leading account name components"
  -- ,flagReq  ["format"] (\s opts -> Right $ setopt "format" s opts) "FORMATSTR" "use this custom line format"
  -- ,flagNone ["no-elide"] (setboolopt "no-elide") "don't compress empty parent accounts on one line"

--uimode :: Mode RawOpts
uimode :: Mode RawOpts
uimode =
  (PackageVersionString
-> RawOpts
-> PackageVersionString
-> Arg RawOpts
-> [Flag RawOpts]
-> Mode RawOpts
forall a.
PackageVersionString
-> a -> PackageVersionString -> Arg a -> [Flag a] -> Mode a
mode PackageVersionString
"hledger-ui" (PackageVersionString -> PackageVersionString -> RawOpts -> RawOpts
setopt PackageVersionString
"command" PackageVersionString
"ui" RawOpts
forall a. Default a => a
def)
    PackageVersionString
"browse accounts, postings and entries in a full-window TUI"
    (PackageVersionString -> Arg RawOpts
argsFlag PackageVersionString
"[--cash|--bs|--is|--all|--register=ACCT] [QUERY]") [])
  {modeGroupFlags = Group {
       groupUnnamed = uiflags
      ,groupHidden = hiddenflags
        ++
        [flagNone ["future"] (setboolopt "forecast") "old flag, use --forecast instead"
        ,flagNone ["menu"] (setboolopt "menu") "old flag, menu screen is now the default"
        ]
      ,groupNamed = mkgeneralflagsgroups1 helpflags
      }
  ,modeHelpSuffix=[
    -- "Reads your ~/.hledger.journal file, or another specified by $LEDGER_FILE or -f, and starts the full-window TUI."
  ]
  }

-- hledger-ui options, used in hledger-ui and above
data UIOpts = UIOpts
  { UIOpts -> Bool
uoWatch    :: Bool
  , UIOpts -> Maybe PackageVersionString
uoTheme    :: Maybe String
  , UIOpts -> Maybe PackageVersionString
uoRegister :: Maybe String
  , UIOpts -> CliOpts
uoCliOpts  :: CliOpts
  } deriving (Int -> UIOpts -> PackageVersionString -> PackageVersionString
[UIOpts] -> PackageVersionString -> PackageVersionString
UIOpts -> PackageVersionString
(Int -> UIOpts -> PackageVersionString -> PackageVersionString)
-> (UIOpts -> PackageVersionString)
-> ([UIOpts] -> PackageVersionString -> PackageVersionString)
-> Show UIOpts
forall a.
(Int -> a -> PackageVersionString -> PackageVersionString)
-> (a -> PackageVersionString)
-> ([a] -> PackageVersionString -> PackageVersionString)
-> Show a
$cshowsPrec :: Int -> UIOpts -> PackageVersionString -> PackageVersionString
showsPrec :: Int -> UIOpts -> PackageVersionString -> PackageVersionString
$cshow :: UIOpts -> PackageVersionString
show :: UIOpts -> PackageVersionString
$cshowList :: [UIOpts] -> PackageVersionString -> PackageVersionString
showList :: [UIOpts] -> PackageVersionString -> PackageVersionString
Show)

defuiopts :: UIOpts
defuiopts = UIOpts
  { uoWatch :: Bool
uoWatch    = Bool
False
  , uoTheme :: Maybe PackageVersionString
uoTheme    = Maybe PackageVersionString
forall a. Maybe a
Nothing
  , uoRegister :: Maybe PackageVersionString
uoRegister = Maybe PackageVersionString
forall a. Maybe a
Nothing
  , uoCliOpts :: CliOpts
uoCliOpts  = CliOpts
defcliopts
  }

-- | Process a RawOpts into a UIOpts.
-- An invalid --theme name will raise an error.
rawOptsToUIOpts :: RawOpts -> IO UIOpts
rawOptsToUIOpts :: RawOpts -> IO UIOpts
rawOptsToUIOpts RawOpts
rawopts = do
  cliopts <- ASetter CliOpts CliOpts BalanceAccumulation BalanceAccumulation
-> BalanceAccumulation -> CliOpts -> CliOpts
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter CliOpts CliOpts BalanceAccumulation BalanceAccumulation
forall c. HasReportOptsNoUpdate c => Lens' c BalanceAccumulation
Lens' CliOpts BalanceAccumulation
balanceaccum BalanceAccumulation
accum (CliOpts -> CliOpts) -> IO CliOpts -> IO CliOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawOpts -> IO CliOpts
rawOptsToCliOpts RawOpts
rawopts
  return
    defuiopts {
       uoWatch    = boolopt "watch" rawopts
      ,uoTheme    = checkTheme <$> maybestringopt "theme" rawopts
      ,uoRegister = maybestringopt "register" rawopts
      ,uoCliOpts  = cliopts
      }
  where
    -- show historical balance by default (unlike hledger)
    accum :: BalanceAccumulation
accum = BalanceAccumulation
-> Maybe BalanceAccumulation -> BalanceAccumulation
forall a. a -> Maybe a -> a
fromMaybe BalanceAccumulation
Historical (Maybe BalanceAccumulation -> BalanceAccumulation)
-> Maybe BalanceAccumulation -> BalanceAccumulation
forall a b. (a -> b) -> a -> b
$ RawOpts -> Maybe BalanceAccumulation
balanceAccumulationOverride RawOpts
rawopts
    checkTheme :: PackageVersionString -> PackageVersionString
checkTheme PackageVersionString
t = if PackageVersionString
t PackageVersionString -> Map PackageVersionString AttrMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map PackageVersionString AttrMap
themes then PackageVersionString
t else PackageVersionString -> PackageVersionString
forall a. PackageVersionString -> a
usageError (PackageVersionString -> PackageVersionString)
-> PackageVersionString -> PackageVersionString
forall a b. (a -> b) -> a -> b
$ PackageVersionString
"invalid theme name: " PackageVersionString
-> PackageVersionString -> PackageVersionString
forall a. [a] -> [a] -> [a]
++ PackageVersionString
t

-- XXX some refactoring seems due
getHledgerUIOpts :: IO UIOpts
--getHledgerUIOpts = processArgs uimode >>= return >>= rawOptsToUIOpts
getHledgerUIOpts :: IO UIOpts
getHledgerUIOpts = do
  args <- IO [PackageVersionString]
getArgs IO [PackageVersionString]
-> ([PackageVersionString] -> IO [PackageVersionString])
-> IO [PackageVersionString]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [PackageVersionString] -> IO [PackageVersionString]
expandArgsAt
  let args' = [PackageVersionString] -> [PackageVersionString]
ensureDebugFlagHasVal ([PackageVersionString] -> [PackageVersionString])
-> [PackageVersionString] -> [PackageVersionString]
forall a b. (a -> b) -> a -> b
$ [PackageVersionString] -> [PackageVersionString]
replaceNumericFlags [PackageVersionString]
args
  let cmdargopts = (PackageVersionString -> RawOpts)
-> (RawOpts -> RawOpts)
-> Either PackageVersionString RawOpts
-> RawOpts
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PackageVersionString -> RawOpts
forall a. PackageVersionString -> a
usageError RawOpts -> RawOpts
forall a. a -> a
id (Either PackageVersionString RawOpts -> RawOpts)
-> Either PackageVersionString RawOpts -> RawOpts
forall a b. (a -> b) -> a -> b
$ Mode RawOpts
-> [PackageVersionString] -> Either PackageVersionString RawOpts
forall a.
Mode a -> [PackageVersionString] -> Either PackageVersionString a
process Mode RawOpts
uimode [PackageVersionString]
args'
  rawOptsToUIOpts cmdargopts

instance HasCliOpts UIOpts where
    cliOpts :: Lens' UIOpts CliOpts
cliOpts CliOpts -> f CliOpts
f UIOpts
uiopts = (\CliOpts
x -> UIOpts
uiopts{uoCliOpts=x}) (CliOpts -> UIOpts) -> f CliOpts -> f UIOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CliOpts -> f CliOpts
f (UIOpts -> CliOpts
uoCliOpts UIOpts
uiopts)

instance HasInputOpts UIOpts where
    inputOpts :: Lens' UIOpts InputOpts
inputOpts = (CliOpts -> f CliOpts) -> UIOpts -> f UIOpts
forall c. HasCliOpts c => Lens' c CliOpts
Lens' UIOpts CliOpts
cliOpts((CliOpts -> f CliOpts) -> UIOpts -> f UIOpts)
-> ((InputOpts -> f InputOpts) -> CliOpts -> f CliOpts)
-> (InputOpts -> f InputOpts)
-> UIOpts
-> f UIOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(InputOpts -> f InputOpts) -> CliOpts -> f CliOpts
forall c. HasInputOpts c => Lens' c InputOpts
Lens' CliOpts InputOpts
inputOpts

instance HasBalancingOpts UIOpts where
    balancingOpts :: Lens' UIOpts BalancingOpts
balancingOpts = (CliOpts -> f CliOpts) -> UIOpts -> f UIOpts
forall c. HasCliOpts c => Lens' c CliOpts
Lens' UIOpts CliOpts
cliOpts((CliOpts -> f CliOpts) -> UIOpts -> f UIOpts)
-> ((BalancingOpts -> f BalancingOpts) -> CliOpts -> f CliOpts)
-> (BalancingOpts -> f BalancingOpts)
-> UIOpts
-> f UIOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BalancingOpts -> f BalancingOpts) -> CliOpts -> f CliOpts
forall c. HasBalancingOpts c => Lens' c BalancingOpts
Lens' CliOpts BalancingOpts
balancingOpts

instance HasReportSpec UIOpts where
    reportSpec :: Lens' UIOpts ReportSpec
reportSpec = (CliOpts -> f CliOpts) -> UIOpts -> f UIOpts
forall c. HasCliOpts c => Lens' c CliOpts
Lens' UIOpts CliOpts
cliOpts((CliOpts -> f CliOpts) -> UIOpts -> f UIOpts)
-> ((ReportSpec -> f ReportSpec) -> CliOpts -> f CliOpts)
-> (ReportSpec -> f ReportSpec)
-> UIOpts
-> f UIOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ReportSpec -> f ReportSpec) -> CliOpts -> f CliOpts
forall c. HasReportSpec c => Lens' c ReportSpec
Lens' CliOpts ReportSpec
reportSpec

instance HasReportOptsNoUpdate UIOpts where
    reportOptsNoUpdate :: Lens' UIOpts ReportOpts
reportOptsNoUpdate = (CliOpts -> f CliOpts) -> UIOpts -> f UIOpts
forall c. HasCliOpts c => Lens' c CliOpts
Lens' UIOpts CliOpts
cliOpts((CliOpts -> f CliOpts) -> UIOpts -> f UIOpts)
-> ((ReportOpts -> f ReportOpts) -> CliOpts -> f CliOpts)
-> (ReportOpts -> f ReportOpts)
-> UIOpts
-> f UIOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ReportOpts -> f ReportOpts) -> CliOpts -> f CliOpts
forall c. HasReportOptsNoUpdate c => Lens' c ReportOpts
Lens' CliOpts ReportOpts
reportOptsNoUpdate

instance HasReportOpts UIOpts where
    reportOpts :: ReportableLens' UIOpts ReportOpts
reportOpts = (CliOpts -> f CliOpts) -> UIOpts -> f UIOpts
forall c. HasCliOpts c => Lens' c CliOpts
Lens' UIOpts CliOpts
cliOpts((CliOpts -> f CliOpts) -> UIOpts -> f UIOpts)
-> ((ReportOpts -> f ReportOpts) -> CliOpts -> f CliOpts)
-> (ReportOpts -> f ReportOpts)
-> UIOpts
-> f UIOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ReportOpts -> f ReportOpts) -> CliOpts -> f CliOpts
forall a. HasReportOpts a => ReportableLens' a ReportOpts
ReportableLens' CliOpts ReportOpts
reportOpts