module Penny.Zinc
( Defaults(..)
, ColorToFile(..)
, Matcher(..)
, SortField(..)
, runZinc
) where
import qualified Penny.Cabin.Chunk as Chk
import qualified Penny.Cabin.Interface as I
import qualified Penny.Cabin.Parsers as P
import qualified Penny.Cabin.Scheme as E
import qualified Penny.Copper as C
import qualified Penny.Liberty as Ly
import qualified Penny.Liberty.Expressions as X
import qualified Penny.Lincoln as L
import qualified Penny.Lincoln.Queries as Q
import qualified Penny.Shield as S
import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (when)
import qualified Control.Monad.Trans.State as St
import qualified Control.Monad.Exception.Synchronous as Ex
import Data.Char (toUpper, toLower)
import Data.List (isPrefixOf)
import Data.Maybe (mapMaybe, catMaybes)
import Data.Monoid (mappend, mconcat)
import Data.Ord (comparing)
import Data.Text (Text, pack, unpack)
import qualified Data.Text.IO as TIO
import qualified System.Console.MultiArg as MA
import System.Console.MultiArg.GetArgs (getArgs)
import System.Exit (exitSuccess, exitFailure)
import qualified System.IO as IO
import System.IO (hIsTerminalDevice, stdin, stderr, hPutStrLn)
import qualified Text.Matchers.Text as M
runZinc
:: Defaults
-> S.Runtime
-> [I.Report]
-> IO ()
runZinc df rt rs = do
as <- getArgs
parseAndPrint df rt rs as
newtype ColorToFile = ColorToFile { unColorToFile :: Bool }
deriving (Eq, Show)
data Matcher
= Within
| Exact
| TDFA
| PCRE
deriving (Eq, Show)
data SortField
= Payee
| Date
| Flag
| Number
| Account
| DrCr
| Qty
| Commodity
| PostingMemo
| TransactionMemo
deriving (Eq, Show, Ord)
data Defaults = Defaults
{ sensitive :: M.CaseSensitive
, matcher :: Matcher
, colorToFile :: ColorToFile
, defaultScheme :: Maybe E.Scheme
, moreSchemes :: [E.Scheme]
, sorter :: [(SortField, P.SortOrder)]
}
sortPairToFn :: (SortField, P.SortOrder) -> Orderer
sortPairToFn (s, d) = if d == P.Descending then flipOrder r else r
where
r = case s of
Payee -> comparing Q.payee
Date -> comparing Q.dateTime
Flag -> comparing Q.flag
Number -> comparing Q.number
Account -> comparing Q.account
DrCr -> comparing Q.drCr
Qty -> comparing Q.qty
Commodity -> comparing Q.commodity
PostingMemo -> comparing Q.postingMemo
TransactionMemo -> comparing Q.transactionMemo
descPair :: (SortField, P.SortOrder) -> String
descPair (i, d) = desc ++ ", " ++ dir
where
dir = case d of
P.Ascending -> "ascending"
P.Descending -> "descending"
desc = case show i of
[] -> []
x:xs -> toLower x : xs
descSortList :: [(SortField, P.SortOrder)] -> [String]
descSortList ls = case ls of
[] -> [" No sorting performed by default"]
x:xs -> descFirst x : map descRest xs
descFirst :: (SortField, P.SortOrder) -> String
descFirst p = " Default sort order: " ++ descPair p
descRest :: (SortField, P.SortOrder) -> String
descRest p = " then: " ++ descPair p
sortPairsToFn :: [(SortField, P.SortOrder)] -> Orderer
sortPairsToFn = mconcat . map sortPairToFn
data State = State
{ stSensitive :: M.CaseSensitive
, stFactory :: M.CaseSensitive -> Text
-> Ex.Exceptional Text (Text -> Bool)
, stColorToFile :: ColorToFile
, stScheme :: Maybe E.TextSpecs
}
stateFromDefaults
:: Defaults
-> State
stateFromDefaults df = State
{ stSensitive = sensitive df
, stFactory = case matcher df of
Within -> \c t -> return (M.within c t)
Exact -> \c t -> return (M.exact c t)
TDFA -> M.tdfa
PCRE -> M.pcre
, stColorToFile = colorToFile df
, stScheme = fmap E.textSpecs . defaultScheme $ df
}
data OptResult
= ROperand (M.CaseSensitive
-> Ly.MatcherFactory
-> Ex.Exceptional String Ly.Operand)
| RPostFilter (Ex.Exceptional String Ly.PostFilterFn)
| RMatcherSelect Ly.MatcherFactory
| RCaseSelect M.CaseSensitive
| ROperator (Ly.Token (L.PostFam -> Bool))
| RSortSpec (Ex.Exceptional String Orderer)
| RHelp
| RColorToFile ColorToFile
| RScheme E.TextSpecs
isHelp :: OptResult -> Bool
isHelp o = case o of { RHelp -> True; _ -> False }
getPostFilters
:: [OptResult]
-> Ex.Exceptional String [Ly.PostFilterFn]
getPostFilters =
sequence
. mapMaybe f
where
f o = case o of
RPostFilter pf -> Just pf
_ -> Nothing
getSortSpec
:: Orderer
-> [OptResult]
-> Ex.Exceptional String Orderer
getSortSpec i ls =
let getSpec o = case o of
RSortSpec x -> Just x
_ -> Nothing
exSpecs = mapMaybe getSpec ls
in if null exSpecs
then return i
else fmap mconcat . sequence $ exSpecs
type Factory = M.CaseSensitive
-> Text -> Ex.Exceptional Text (Text -> Bool)
makeToken
:: OptResult
-> St.State (M.CaseSensitive, Factory)
(Maybe (Ex.Exceptional String (Ly.Token (L.PostFam -> Bool))))
makeToken o = case o of
ROperand f -> do
(s, fty) <- St.get
let g = fmap h (f s fty)
h (X.Operand fn) = Ly.TokOperand fn
return (Just g)
RMatcherSelect f -> do
(c, _) <- St.get
St.put (c, f)
return Nothing
RCaseSelect c -> do
(_, f) <- St.get
St.put (c, f)
return Nothing
ROperator t -> return . Just . return $ t
_ -> return Nothing
makeTokens
:: State
-> [OptResult]
-> Ex.Exceptional String ( [Ly.Token (L.PostFam -> Bool)]
, (M.CaseSensitive, Factory) )
makeTokens df os =
let initSt = (stSensitive df, stFactory df)
lsSt = mapM makeToken os
(ls, st') = St.runState lsSt initSt
in fmap (\xs -> (xs, st')) . sequence . catMaybes $ ls
allOpts :: L.DateTime -> Defaults -> [MA.OptSpec OptResult]
allOpts dt df =
map (fmap ROperand) (Ly.operandSpecs dt)
++ [fmap RPostFilter . fst $ Ly.postFilterSpecs]
++ [fmap RPostFilter . snd $ Ly.postFilterSpecs]
++ map (fmap RMatcherSelect) Ly.matcherSelectSpecs
++ map (fmap RCaseSelect) Ly.caseSelectSpecs
++ map (fmap ROperator) Ly.operatorSpecs
++ [fmap RSortSpec sortSpecs]
++ [ MA.OptSpec ["help"] "h" (MA.NoArg RHelp)
, optColorToFile ]
++ let ss = moreSchemes df
in if not . null $ ss then [optScheme ss] else []
optColorToFile :: MA.OptSpec OptResult
optColorToFile = MA.OptSpec ["color-to-file"] "" (MA.ChoiceArg ls)
where
ls = [ ("yes", RColorToFile $ ColorToFile True)
, ("no", RColorToFile $ ColorToFile False) ]
getColorToFile :: State -> [OptResult] -> ColorToFile
getColorToFile d ls =
case mapMaybe getOpt ls of
[] -> stColorToFile d
xs -> last xs
where
getOpt o = case o of
RColorToFile c -> Just c
_ -> Nothing
optScheme :: [E.Scheme] -> MA.OptSpec OptResult
optScheme ss = MA.OptSpec ["scheme"] "" (MA.ChoiceArg ls)
where
ls = map f ss
f (E.Scheme n _ s) = (n, RScheme s)
getScheme :: State -> [OptResult] -> Maybe E.TextSpecs
getScheme d ls =
case mapMaybe getOpt ls of
[] -> stScheme d
xs -> Just $ last xs
where
getOpt o = case o of
RScheme s -> Just s
_ -> Nothing
data GlobalResult
= NeedsHelp
| RunPenny FilterOpts
data FilterOpts = FilterOpts
{ _resultFactory :: M.CaseSensitive
-> Text -> Ex.Exceptional Text (Text -> Bool)
, _resultSensitive :: M.CaseSensitive
, _sorterFilterer :: [L.Transaction] -> [L.Box Ly.LibertyMeta]
, foTextSpecs :: Maybe E.TextSpecs
, foColorToFile :: ColorToFile
}
processGlobal
:: Orderer
-> State
-> [OptResult]
-> Ex.Exceptional String GlobalResult
processGlobal srt st os =
if any isHelp os
then return NeedsHelp
else do
postFilts <- getPostFilters os
sortSpec <- getSortSpec srt os
(toks, (rs, rf)) <- makeTokens st os
let ctf = getColorToFile st os
sch = getScheme st os
err = "could not parse filter expression."
pdct <- Ex.fromMaybe err $ Ly.parsePredicate toks
let sf = Ly.xactionsToFiltered pdct postFilts sortSpec
fo = FilterOpts rf rs sf sch ctf
return $ RunPenny fo
warnTerminal :: IO ()
warnTerminal =
hPutStrLn stderr $ "penny: warning: reading from standard input, "
++ "which is a terminal"
data Filename =
Filename Text
| Stdin
convertFilename :: Filename -> L.Filename
convertFilename (Filename x) = L.Filename x
convertFilename Stdin = L.Filename . pack $ "<stdin>"
ledgerText :: Filename -> IO Text
ledgerText f = case f of
Stdin -> do
isTerm <- hIsTerminalDevice stdin
when isTerm warnTerminal
TIO.hGetContents stdin
Filename fn -> TIO.readFile (unpack fn)
toFilename :: String -> Filename
toFilename s =
if s == "-"
then Stdin
else Filename . pack $ s
readLedgers :: [String] -> IO [(Filename, Text)]
readLedgers ss =
let fns = if null ss then [Stdin] else map toFilename ss
f fn = (\txt -> (fn, txt)) <$> ledgerText fn
in mapM f fns
parseLedgers
:: [(Filename, Text)]
-> Ex.Exceptional String ([L.Transaction], [L.PricePoint])
parseLedgers ls =
let toPair (f, t) = (convertFilename f, C.FileContents t)
parsed = C.parse (map toPair ls)
folder i (ts, ps) = case i of
C.Transaction t -> (t:ts, ps)
C.PricePoint p -> (ts, p:ps)
_ -> (ts, ps)
toResult (C.Ledger is) = foldr folder ([], []) is
toErr x = "could not parse ledger: "
++ (unpack . C.unErrorMsg $ x)
in Ex.mapExceptional toErr toResult parsed
data DisplayOpts = DisplayOpts ColorToFile (Maybe E.TextSpecs)
toDisplayOpts :: FilterOpts -> DisplayOpts
toDisplayOpts o = DisplayOpts (foColorToFile o) (foTextSpecs o)
parseCommandLine
:: Defaults
-> [I.Report]
-> S.Runtime
-> [String]
-> Ex.Exceptional MA.Error
(GlobalResult, Either [()] (DisplayOpts, I.ParseResult))
parseCommandLine df rs rt ss =
let initSt = stateFromDefaults df
in MA.modes (allOpts (S.currentTime rt) df)
(processGlobal (sortPairsToFn . sorter $ df) initSt)
(whatMode rt rs) ss
whatMode
:: S.Runtime
-> [I.Report]
-> GlobalResult
-> Either (a -> ()) [MA.Mode (DisplayOpts, I.ParseResult)]
whatMode rt pairFns gr =
case gr of
NeedsHelp -> Left $ const ()
RunPenny fo@(FilterOpts fty cs sf _ _) ->
let prs = map snd (pairFns <*> pure rt)
<*> pure cs
<*> pure fty
<*> pure sf
in Right $ map (fmap (\r -> ((toDisplayOpts fo), r))) prs
handleParseResult
:: S.Runtime
-> Defaults
-> [I.Report]
-> Ex.Exceptional MA.Error
(a, Either b (DisplayOpts, I.ParseResult))
-> IO ()
handleParseResult rt df rs r =
let showErr e = do
IO.hPutStrLn IO.stderr $ "penny: error: " ++ e
exitFailure
in case r of
Ex.Exception e -> do
IO.hPutStr IO.stderr $ MA.formatError "penny" e
exitFailure
Ex.Success (_, ei) ->
case ei of
Left _ -> putStr (helpText df rt rs) >> exitSuccess
Right ((DisplayOpts ctf sch), ex) -> case ex of
Ex.Exception s -> showErr s
Ex.Success good -> either showHelp runCmd good
where
showHelp h = putStr h >> exitSuccess
runCmd (fns, pr) = do
ledgers <- readLedgers fns
(txns, pps) <- Ex.switch showErr return
$ parseLedgers ledgers
let term = if unColorToFile ctf
then Chk.termFromEnv rt
else Chk.autoTerm rt
Ex.switch (showErr . unpack)
(printChunks term sch) $ pr txns pps
printChunks
:: Chk.Term
-> Maybe E.TextSpecs
-> [E.PreChunk]
-> IO ()
printChunks t mayS =
Chk.printChunks t
. map makeChunk
where
makeChunk pc = case mayS of
Nothing -> Chk.chunk Chk.defaultTextSpec (E.text pc)
Just s -> E.makeChunk s pc
helpText
:: Defaults
-> S.Runtime
-> [I.Report]
-> String
helpText df rt pairMakers =
mappend (help df) . mconcat . map addHdr . fmap fst $ pairs
where
pairs = pairMakers <*> pure rt
addHdr s = hdr ++ s
hdr = unlines [ "", replicate 50 '=' ]
parseAndPrint
:: Defaults
-> S.Runtime
-> [I.Report]
-> [String]
-> IO ()
parseAndPrint df rt rs ss =
handleParseResult rt df rs
$ parseCommandLine df rs rt ss
type Orderer = L.PostFam -> L.PostFam -> Ordering
flipOrder :: (a -> a -> Ordering) -> (a -> a -> Ordering)
flipOrder f = f' where
f' p1 p2 = case f p1 p2 of
LT -> GT
GT -> LT
EQ -> EQ
capitalizeFirstLetter :: String -> String
capitalizeFirstLetter s = case s of
[] -> []
(x:xs) -> toUpper x : xs
ordPairs :: [(String, Orderer)]
ordPairs =
[ ("payee", comparing Q.payee)
, ("date", comparing Q.dateTime)
, ("flag", comparing Q.flag)
, ("number", comparing Q.number)
, ("account", comparing Q.account)
, ("drCr", comparing Q.drCr)
, ("qty", comparing Q.qty)
, ("commodity", comparing Q.commodity)
, ("postingMemo", comparing Q.postingMemo)
, ("transactionMemo", comparing Q.transactionMemo) ]
ords :: [(String, Orderer)]
ords = ordPairs ++ uppers ++ [none] where
uppers = map toReversed ordPairs
toReversed (s, f) =
(capitalizeFirstLetter s, flipOrder f)
none = ("none", const . const $ EQ)
argMatch :: String -> String -> Bool
argMatch s1 s2 = case (s1, s2) of
(x:xs, y:ys) ->
(x == y) && ((map toUpper xs) `isPrefixOf` (map toUpper ys))
_ -> True
sortSpecs :: MA.OptSpec (Ex.Exceptional String Orderer)
sortSpecs = MA.OptSpec ["sort"] ['s'] (MA.OneArg f)
where
f a =
let matches = filter (\p -> a `argMatch` (fst p)) ords
in case matches of
x:[] -> return $ snd x
_ -> Ex.throw $ "invalid sort key: " ++ a
help :: Defaults -> String
help d = unlines $
[ "usage: penny [posting filters] report [report options] file . . ."
, ""
, "Posting filters"
, "------------------------------------------"
, ""
, "Dates"
, "-----"
, ""
, "--date cmp timespec, -d cmp timespec"
, " Date must be within the time frame given. timespec"
, " is a day or a day and a time. Valid values for cmp:"
, " <, >, <=, >=, ==, /=, !="
, "--current"
, " Same as \"--date <= (right now) \""
, ""
, "Serials"
, "----------------"
, "These options take the form --option cmp num; the given"
, "sequence number must fall within the given range. \"rev\""
, "in the option name indicates numbering is from end to beginning."
, ""
, "--globalTransaction, --revGlobalTransaction"
, " All transactions, after reading the ledger files"
, "--globalPosting, --revGlobalPosting"
, " All postings, after reading the leder files"
, "--fileTransaction, --revFileTransaction"
, " Transactions in each ledger file, after reading the files"
, " (numbering restarts with each file)"
, "--filePosting, --revFilePosting"
, " Postings in each ledger file, after reading the files"
, " (numbering restarts with each file)"
, ""
, "Pattern matching"
, "----------------"
, ""
, "-a pattern, --account pattern"
, " Pattern must match colon-separated account name"
, "--account-level num pat"
, " Pattern must match sub account at given level"
, "--account-any pat"
, " Pattern must match sub account at any level"
, "-p pattern, --payee pattern"
, " Payee must match pattern"
, "-t pattern, --tag pattern"
, " Tag must match pattern"
, "--number pattern"
, " Number must match pattern"
, "--flag pattern"
, " Flag must match pattern"
, "--commodity pattern"
, " Pattern must match colon-separated commodity name"
, "--posting-memo pattern"
, " Posting memo must match pattern"
, "--transaction-memo pattern"
, " Transaction memo must match pattern"
, ""
, "Other posting characteristics"
, "-----------------------------"
, "--debit"
, " Entry must be a debit"
, "--credit"
, " Entry must be a credit"
, "--qty cmp number"
, " Entry quantity must fall within given range"
, ""
, "Operators - from highest to lowest precedence"
, "(all are left associative)"
, "--------------------------"
, "--open expr --close"
, " Force precedence (as in \"open\" and \"close\" parentheses)"
, "--not expr"
, " True if expr is false"
, "expr1 --and expr2 "
, " True if expr and expr2 are both true"
, "expr1 --or expr2"
, " True if either expr1 or expr2 is true"
, ""
, "Options affecting patterns"
, "--------------------------"
, ""
, "-i, --case-insensitive"
, " Be case insensitive"
++ ifDefault (sensitive d == M.Insensitive)
, "-I, --case-sensitive"
, " Be case sensitive"
++ ifDefault (sensitive d == M.Sensitive)
, ""
, "--within"
, " Use \"within\" matcher"
++ ifDefault (matcher d == Within)
, "--pcre"
, " Use \"pcre\" matcher"
++ ifDefault (matcher d == PCRE)
, "--posix"
, " Use \"posix\" matcher"
++ ifDefault (matcher d == TDFA)
, "--exact"
, " Use \"exact\" matcher"
++ ifDefault (matcher d == Exact)
, ""
, "Removing postings after sorting and filtering"
, "---------------------------------------------"
, "--head n"
, " Keep only the first n postings"
, "--tail n"
, " Keep only the last n postings"
, ""
, "Sorting"
, "-------"
, ""
, "-s key, --sort key"
, " Sort postings according to key"
, ""
, "Keys:"
, " payee, date, flag, number, account, drCr,"
, " qty, commodity, postingMemo, transactionMemo"
, ""
, " Ascending order by default; for descending order,"
, " capitalize the name of the key."
, " (use \"none\" to leave postings in ledger file order)"
, ""
] ++ descSortList (sorter d) ++
[ ""
, "Colors"
, "------"
, "default scheme:"
, maybe " (none)" descScheme (defaultScheme d)
, ""
]
++ let schs = moreSchemes d
in (if not . null $ schs
then
[ "--scheme SCHEME_NAME"
, " use color scheme for report. Available schemes:"
] ++ map descScheme schs
else [])
++
[ ""
, "--color-to-file no|yes"
, " Whether to use color when standard output is not a"
, " terminal (default: " ++
if unColorToFile . colorToFile $ d then "yes)" else "no)"
]
descScheme :: E.Scheme -> String
descScheme (E.Scheme n d _) = " " ++ n ++ " - " ++ d
ifDefault :: Bool -> String
ifDefault b = if b then " (default)" else ""