{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

module Hledger.Cli.Commands.Tags (
  tagsmode
 ,tags
)
where

import Control.Monad.Fail qualified as Fail
import Data.List.Extra (nubSort)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Safe
import System.Console.CmdArgs.Explicit

import Hledger
import Hledger.Cli.CliOptions
import Data.Function ((&))
import Data.Maybe (fromMaybe)
import Data.List (find)


tagsmode :: Mode RawOpts
tagsmode = CommandHelpStr
-> [Flag RawOpts]
-> [(CommandHelpStr, [Flag RawOpts])]
-> [Flag RawOpts]
-> ([Arg RawOpts], Maybe (Arg RawOpts))
-> Mode RawOpts
hledgerCommandMode
  $(embedFileRelative "Hledger/Cli/Commands/Tags.txt")
  [
   [CommandHelpStr]
-> (RawOpts -> RawOpts) -> CommandHelpStr -> Flag RawOpts
forall a. [CommandHelpStr] -> (a -> a) -> CommandHelpStr -> Flag a
flagNone [CommandHelpStr
"used"]         (CommandHelpStr -> RawOpts -> RawOpts
setboolopt CommandHelpStr
"used")       CommandHelpStr
"list tags used"
  ,[CommandHelpStr]
-> (RawOpts -> RawOpts) -> CommandHelpStr -> Flag RawOpts
forall a. [CommandHelpStr] -> (a -> a) -> CommandHelpStr -> Flag a
flagNone [CommandHelpStr
"declared"]     (CommandHelpStr -> RawOpts -> RawOpts
setboolopt CommandHelpStr
"declared")   CommandHelpStr
"list tags declared"
  ,[CommandHelpStr]
-> (RawOpts -> RawOpts) -> CommandHelpStr -> Flag RawOpts
forall a. [CommandHelpStr] -> (a -> a) -> CommandHelpStr -> Flag a
flagNone [CommandHelpStr
"undeclared"]   (CommandHelpStr -> RawOpts -> RawOpts
setboolopt CommandHelpStr
"undeclared") CommandHelpStr
"list tags used but not declared"
  ,[CommandHelpStr]
-> (RawOpts -> RawOpts) -> CommandHelpStr -> Flag RawOpts
forall a. [CommandHelpStr] -> (a -> a) -> CommandHelpStr -> Flag a
flagNone [CommandHelpStr
"unused"]       (CommandHelpStr -> RawOpts -> RawOpts
setboolopt CommandHelpStr
"unused")     CommandHelpStr
"list tags declared but not used"
  ,[CommandHelpStr]
-> (RawOpts -> RawOpts) -> CommandHelpStr -> Flag RawOpts
forall a. [CommandHelpStr] -> (a -> a) -> CommandHelpStr -> Flag a
flagNone [CommandHelpStr
"find"]         (CommandHelpStr -> RawOpts -> RawOpts
setboolopt CommandHelpStr
"find")       CommandHelpStr
"list the first tag whose name is matched by the first argument (a case-insensitive infix regexp)"
  ,[CommandHelpStr]
-> (RawOpts -> RawOpts) -> CommandHelpStr -> Flag RawOpts
forall a. [CommandHelpStr] -> (a -> a) -> CommandHelpStr -> Flag a
flagNone [CommandHelpStr
"values"]       (CommandHelpStr -> RawOpts -> RawOpts
setboolopt CommandHelpStr
"values")     CommandHelpStr
"list tag values instead of tag names"
  ,[CommandHelpStr]
-> (RawOpts -> RawOpts) -> CommandHelpStr -> Flag RawOpts
forall a. [CommandHelpStr] -> (a -> a) -> CommandHelpStr -> Flag a
flagNone [CommandHelpStr
"parsed"]       (CommandHelpStr -> RawOpts -> RawOpts
setboolopt CommandHelpStr
"parsed")     CommandHelpStr
"show them in the order they were parsed (mostly), including duplicates"
  ]
  [(CommandHelpStr, [Flag RawOpts])]
cligeneralflagsgroups1
  [Flag RawOpts]
hiddenflags
  ([], Arg RawOpts -> Maybe (Arg RawOpts)
forall a. a -> Maybe a
Just (Arg RawOpts -> Maybe (Arg RawOpts))
-> Arg RawOpts -> Maybe (Arg RawOpts)
forall a b. (a -> b) -> a -> b
$ CommandHelpStr -> Arg RawOpts
argsFlag CommandHelpStr
"[TAGREGEX [QUERY..]]")

tags :: CliOpts -> Journal -> IO ()
tags :: CliOpts -> Journal -> IO ()
tags opts :: CliOpts
opts@CliOpts{rawopts_ :: CliOpts -> RawOpts
rawopts_=RawOpts
rawopts, reportspec_ :: CliOpts -> ReportSpec
reportspec_=rspec :: ReportSpec
rspec@ReportSpec{_rsQuery :: ReportSpec -> Query
_rsQuery=Query
_q, _rsReportOpts :: ReportSpec -> ReportOpts
_rsReportOpts=ReportOpts
ropts}} Journal
j = do
  let today :: Day
today = ReportSpec -> Day
_rsDay ReportSpec
rspec
      args :: [CommandHelpStr]
args = CommandHelpStr -> RawOpts -> [CommandHelpStr]
listofstringopt CommandHelpStr
"args" RawOpts
rawopts
  -- For convenience/power, the first argument is a tag name regex, 
  -- separate from the main query arguments: hledger tags [TAGREGEX [QUERYARGS..]]
  -- So we have to re-parse the query here. Overcomplicated ?
  mtagpat <- (CommandHelpStr -> IO Regexp)
-> Maybe CommandHelpStr -> IO (Maybe Regexp)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ((CommandHelpStr -> IO Regexp)
-> (Regexp -> IO Regexp)
-> Either CommandHelpStr Regexp
-> IO Regexp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CommandHelpStr -> IO Regexp
forall a. CommandHelpStr -> IO a
forall (m :: * -> *) a. MonadFail m => CommandHelpStr -> m a
Fail.fail Regexp -> IO Regexp
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CommandHelpStr Regexp -> IO Regexp)
-> (CommandHelpStr -> Either CommandHelpStr Regexp)
-> CommandHelpStr
-> IO Regexp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either CommandHelpStr Regexp
toRegexCI (Text -> Either CommandHelpStr Regexp)
-> (CommandHelpStr -> Text)
-> CommandHelpStr
-> Either CommandHelpStr Regexp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandHelpStr -> Text
T.pack) (Maybe CommandHelpStr -> IO (Maybe Regexp))
-> Maybe CommandHelpStr -> IO (Maybe Regexp)
forall a b. (a -> b) -> a -> b
$ [CommandHelpStr] -> Maybe CommandHelpStr
forall a. [a] -> Maybe a
headMay [CommandHelpStr]
args
  let
    values   = CommandHelpStr -> RawOpts -> Bool
boolopt CommandHelpStr
"values" RawOpts
rawopts
    parsed   = CommandHelpStr -> RawOpts -> Bool
boolopt CommandHelpStr
"parsed" RawOpts
rawopts
    empty    = ReportOpts -> Bool
empty_ ReportOpts
ropts
    querystr = (CommandHelpStr -> Text) -> [CommandHelpStr] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map CommandHelpStr -> Text
T.pack ([CommandHelpStr] -> [Text]) -> [CommandHelpStr] -> [Text]
forall a b. (a -> b) -> a -> b
$ Int -> [CommandHelpStr] -> [CommandHelpStr]
forall a. Int -> [a] -> [a]
drop Int
1 [CommandHelpStr]
args
  query <- either usageError (return . fst) $ parseQueryList today querystr
  let
    q = Query -> Query
simplifyQuery (Query -> Query) -> Query -> Query
forall a b. (a -> b) -> a -> b
$ [Query] -> Query
And [ReportOpts -> Query
queryFromFlags ReportOpts
ropts, Query
query]
    txns = (Transaction -> Bool) -> [Transaction] -> [Transaction]
forall a. (a -> Bool) -> [a] -> [a]
filter (Query
q Query -> Transaction -> Bool
`matchesTransaction`) ([Transaction] -> [Transaction]) -> [Transaction] -> [Transaction]
forall a b. (a -> b) -> a -> b
$ Journal -> [Transaction]
jtxns (Journal -> [Transaction]) -> Journal -> [Transaction]
forall a b. (a -> b) -> a -> b
$ ReportSpec -> Journal -> Journal
journalApplyValuationFromOpts ReportSpec
rspec Journal
j
    accts =
      -- also search for tags in matched account declarations,
      -- unless there is a query for something transaction-specific, like date: or amt:.
      if CommandHelpStr -> Bool -> Bool
forall a. Show a => CommandHelpStr -> a -> a
dbg5 CommandHelpStr
"queryIsTransactionRelated" (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Query -> Bool
queryIsTransactionRelated (Query -> Bool) -> Query -> Bool
forall a b. (a -> b) -> a -> b
$ CommandHelpStr -> Query -> Query
forall a. Show a => CommandHelpStr -> a -> a
dbg4 CommandHelpStr
"q" Query
q
      then []
      else (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Maybe AccountType)
-> (Text -> [Tag]) -> Query -> Text -> Bool
matchesAccountExtra (Journal -> Text -> Maybe AccountType
journalAccountType Journal
j) (Journal -> Text -> [Tag]
journalInheritedAccountTags Journal
j) Query
q) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
           ((Text, AccountDeclarationInfo) -> Text)
-> [(Text, AccountDeclarationInfo)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, AccountDeclarationInfo) -> Text
forall a b. (a, b) -> a
fst ([(Text, AccountDeclarationInfo)] -> [Text])
-> [(Text, AccountDeclarationInfo)] -> [Text]
forall a b. (a -> b) -> a -> b
$ Journal -> [(Text, AccountDeclarationInfo)]
jdeclaredaccounts Journal
j
    -- bit of a mess.
    used       = CommandHelpStr -> [Tag] -> [Tag]
forall a. Show a => CommandHelpStr -> a -> a
dbg5 CommandHelpStr
"used"       ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ (Text -> [Tag]) -> [Text] -> [Tag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Journal -> Text -> [Tag]
journalAccountTags Journal
j) [Text]
accts [Tag] -> [Tag] -> [Tag]
forall a. [a] -> [a] -> [a]
++ (Transaction -> [Tag]) -> [Transaction] -> [Tag]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Transaction -> [Tag]
transactionAllTags [Transaction]
txns
    declared'  = CommandHelpStr -> [Tag] -> [Tag]
forall a. Show a => CommandHelpStr -> a -> a
dbg5 CommandHelpStr
"declared'"  ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ (Text -> Tag) -> [Text] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map (,Text
"") ([Text] -> [Tag]) -> [Text] -> [Tag]
forall a b. (a -> b) -> a -> b
$ Journal -> [Text]
journalTagsDeclared Journal
j
    filtereddeclared  = CommandHelpStr -> [Tag] -> [Tag]
forall a. Show a => CommandHelpStr -> a -> a
dbg5 CommandHelpStr
"filtereddeclared'"  ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ (Tag -> Bool) -> [Tag] -> [Tag]
forall a. (a -> Bool) -> [a] -> [a]
filter (Query
q Query -> Tag -> Bool
`matchesTag`) [Tag]
declared'
    (usednames, declarednames) = (map fst used, map fst filtereddeclared)
    unused     = CommandHelpStr -> [Tag] -> [Tag]
forall a. Show a => CommandHelpStr -> a -> a
dbg5 CommandHelpStr
"unused"     ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ (Tag -> Bool) -> [Tag] -> [Tag]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Tag -> Bool) -> Tag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
usednames) (Text -> Bool) -> (Tag -> Text) -> Tag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Text
forall a b. (a, b) -> a
fst) [Tag]
filtereddeclared
    undeclared = CommandHelpStr -> [Tag] -> [Tag]
forall a. Show a => CommandHelpStr -> a -> a
dbg5 CommandHelpStr
"undeclared" ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ (Tag -> Bool) -> [Tag] -> [Tag]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Tag -> Bool) -> Tag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
declarednames) (Text -> Bool) -> (Tag -> Text) -> Tag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Text
forall a b. (a, b) -> a
fst) [Tag]
used
    all'       = CommandHelpStr -> [Tag] -> [Tag]
forall a. Show a => CommandHelpStr -> a -> a
dbg5 CommandHelpStr
"all''"      ([Tag] -> [Tag]) -> [Tag] -> [Tag]
forall a b. (a -> b) -> a -> b
$ [Tag]
filtereddeclared [Tag] -> [Tag] -> [Tag]
forall a. Semigroup a => a -> a -> a
<> [Tag]
used
    found      = CommandHelpStr -> Tag -> Tag
forall a. Show a => CommandHelpStr -> a -> a
dbg5 CommandHelpStr
"found"      (Tag -> Tag) -> Tag -> Tag
forall a b. (a -> b) -> a -> b
$ Tag
foundtag
      where
        -- First find the name, then the first occurrence of that tag.
        -- So that --values and --parsed still work with --find (in some reasonably stable way).
        alltags :: [Tag]
alltags = [Tag]
declared' [Tag] -> [Tag] -> [Tag]
forall a. Semigroup a => a -> a -> a
<> [Tag]
used
        allnames :: [Text]
allnames = CommandHelpStr -> [Text] -> [Text]
forall a. Show a => CommandHelpStr -> a -> a
dbg5 CommandHelpStr
"allnames" ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
nubSort ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Tag -> Text) -> [Tag] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Tag -> Text
forall a b. (a, b) -> a
fst [Tag]
alltags
        foundname :: Text
foundname = CommandHelpStr -> Text -> Text
forall a. Show a => CommandHelpStr -> a -> a
dbg5 CommandHelpStr
"foundname" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ RawOpts -> CommandHelpStr -> [Text] -> Text
findMatchedByArgument RawOpts
rawopts CommandHelpStr
"tag name" [Text]
allnames
        foundtag :: Tag
foundtag = (Tag -> Bool) -> [Tag] -> Maybe Tag
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
foundname)(Text -> Bool) -> (Tag -> Text) -> Tag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Tag -> Text
forall a b. (a, b) -> a
fst) [Tag]
alltags
          Maybe Tag -> (Maybe Tag -> Tag) -> Tag
forall a b. a -> (a -> b) -> b
& Tag -> Maybe Tag -> Tag
forall a. a -> Maybe a -> a
fromMaybe (CommandHelpStr -> Tag
forall a. CommandHelpStr -> a
error' CommandHelpStr
"tags: could not find a tag's first occurrence")  -- PARTIAL: should not happen because allnames and alltags correspond

    tags' =
      case CliOpts -> Maybe DeclarablesSelector
declarablesSelectorFromOpts CliOpts
opts of
        Maybe DeclarablesSelector
Nothing         -> [Tag]
all'
        Just DeclarablesSelector
Used       -> [Tag]
used
        Just DeclarablesSelector
Declared   -> [Tag]
declared'
        Just DeclarablesSelector
Undeclared -> [Tag]
undeclared
        Just DeclarablesSelector
Unused     -> [Tag]
unused
        Just DeclarablesSelector
Find       -> [Tag
found]

    results =
      (if Bool
parsed then [Text] -> [Text]
forall a. a -> a
id else [Text] -> [Text]
forall a. Ord a => [a] -> [a]
nubSort)
      [ Text
r
      | (Text
t,Text
v) <- [Tag]
tags'
      , Bool -> (Regexp -> Bool) -> Maybe Regexp -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Regexp -> Text -> Bool
`regexMatchText` Text
t) Maybe Regexp
mtagpat
      , let r :: Text
r = if Bool
values then Text
v else Text
t
      , Bool -> Bool
not (Bool
values Bool -> Bool -> Bool
&& Text -> Bool
T.null Text
v Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
empty)
      ]

  mapM_ T.putStrLn results