module Penny.Liberty (
MatcherFactory,
FilteredNum(FilteredNum, unFilteredNum),
SortedNum(SortedNum, unSortedNum),
LibertyMeta(filteredNum, sortedNum),
xactionsToFiltered,
ListLength(ListLength, unListLength),
ItemIndex(ItemIndex, unItemIndex),
PostFilterFn,
parseComparer,
processPostFilters,
parsePredicate,
parseInt,
parseIntMA,
parseInfix,
parseRPN,
exprDesc,
showExpression,
verboseFilter,
Operand,
operandSpecs,
postFilterSpecs,
matcherSelectSpecs,
caseSelectSpecs,
operatorSpecs,
version,
output,
processOutput,
Error
) where
import Control.Arrow (first, second)
import Control.Applicative ((<*>), (<$>), pure, Applicative)
import Data.Char (toUpper)
import Data.Monoid ((<>))
import Data.List (sortBy)
import Data.Text (Text, pack)
import qualified Data.Text as X
import qualified Data.Text.IO as TIO
import qualified Data.Time as Time
import qualified System.Console.MultiArg as MA
import System.Console.MultiArg (InputError(..))
import qualified System.Console.MultiArg.Combinator as C
import System.Console.MultiArg.Combinator (OptSpec)
import Text.Parsec (parse)
import qualified Penny.Copper.Parsec as Pc
import qualified Penny.Lincoln.Predicates as P
import qualified Penny.Lincoln.Queries as Q
import qualified Penny.Lincoln.Predicates.Siblings as PS
import qualified Data.Prednote.Pdct as E
import qualified Penny.Lincoln as L
import qualified System.Console.Rainbow as C
import qualified Data.Prednote.Expressions as X
import Text.Matchers (
CaseSensitive(Sensitive, Insensitive))
import qualified Text.Matchers as TM
#ifdef incabal
import qualified Paths_penny as PPL
#endif
import qualified Data.Version as V
type Error = Text
newtype FilteredNum = FilteredNum { unFilteredNum :: L.Serial }
deriving Show
newtype SortedNum = SortedNum { unSortedNum :: L.Serial }
deriving Show
data LibertyMeta =
LibertyMeta { filteredNum :: FilteredNum
, sortedNum :: SortedNum }
deriving Show
parsePredicate
:: X.ExprDesc
-> [X.Token a]
-> Either Error (E.Pdct a)
parsePredicate d ls = case ls of
[] -> return E.always
_ -> X.parseExpression d ls
xactionsToFiltered
:: P.LPdct
-> [PostFilterFn]
-> (L.Posting -> L.Posting -> Ordering)
-> [L.Transaction]
-> ( (L.Amount L.Qty -> X.Text) -> [C.Chunk]
, [(LibertyMeta, L.Posting)])
xactionsToFiltered pdct postFilts srtr
= second (processPostings srtr postFilts)
. mainFilter pdct
. concatMap L.transactionToPostings
processPostings
:: (L.Posting -> L.Posting -> Ordering)
-> [PostFilterFn]
-> [L.Posting]
-> [(LibertyMeta, L.Posting)]
processPostings srtr postFilters
= (map . first . uncurry $ LibertyMeta)
. addSortedNum
. sortBy (\p1 p2 -> srtr (snd p1) (snd p2))
. processPostFilters postFilters
. addFilteredNum
mainFilter
:: P.LPdct
-> [L.Posting]
-> ((L.Amount L.Qty -> X.Text) -> [C.Chunk], [L.Posting])
mainFilter pdct pstgs = (getChks, ps')
where
ps' = E.filter pdct pstgs
getChks fmt = fst $ E.verboseFilter (L.display fmt) indentAmt
False pdct pstgs
addFilteredNum :: [a] -> [(FilteredNum, a)]
addFilteredNum = L.serialItems (\s p -> (FilteredNum s, p))
addSortedNum :: [(a, b)] -> [((a, SortedNum), b)]
addSortedNum = L.serialItems (\s (a, b) -> ((a, SortedNum s), b))
indentAmt :: E.IndentAmt
indentAmt = 4
type MatcherFactory
= CaseSensitive
-> Text
-> Either Text TM.Matcher
newtype ListLength = ListLength { unListLength :: Int }
deriving (Eq, Ord, Show)
newtype ItemIndex = ItemIndex { unItemIndex :: Int }
deriving (Eq, Ord, Show)
type PostFilterFn = ListLength -> ItemIndex -> Bool
processPostFilters :: [PostFilterFn] -> [a] -> [a]
processPostFilters pfs ls = foldl processPostFilter ls pfs
processPostFilter :: [a] -> PostFilterFn -> [a]
processPostFilter as fn = map fst . filter fn' $ zipped where
len = ListLength $ length as
fn' (_, idx) = fn len (ItemIndex idx)
zipped = zip as [0..]
getMatcher
:: String
-> CaseSensitive
-> MatcherFactory
-> Either Error TM.Matcher
getMatcher s cs f
= either (Left . mkError) Right
$ f cs (pack s)
where
mkError eMsg = "bad pattern: \"" <> pack s <> " - " <> eMsg
<> "\n"
parseComparer
:: String
-> (Ordering -> E.Pdct a)
-> Either InputError (E.Pdct a)
parseComparer s f
= maybe (Left . MA.ErrorMsg $ "bad comparer")
Right $ E.parseComparer (pack s) f
parseDate :: String -> Either InputError Time.UTCTime
parseDate arg =
either (Left . err) (Right . L.toUTC)
. parse Pc.dateTime ""
. pack
$ arg
where
err msg = MA.ErrorMsg $ "bad date - " <> show msg
type Operand = E.Pdct L.Posting
date :: OptSpec Operand
date = C.OptSpec ["date"] ['d'] (C.TwoArg f)
where
f a1 a2 = do
utct <- parseDate a2
parseComparer a1 (flip P.date utct)
current :: L.DateTime -> OptSpec Operand
current dt = C.OptSpec ["current"] [] (C.NoArg f)
where
f = E.or [P.date LT (L.toUTC dt), P.date EQ (L.toUTC dt)]
readMaybe :: Read a => String -> Maybe a
readMaybe s = case reads s of
(i, ""):[] -> return i
_ -> Nothing
parseInt :: String -> Either Error Int
parseInt t =
case readMaybe t of
Just i -> return i
_ -> Left $ "could not parse integer: \"" <> pack t <> "\""
parseIntMA :: String -> Either MA.InputError Int
parseIntMA t
= maybe (Left (ErrorMsg "could not parse integer")) Right
$ readMaybe t
patternOption ::
String
-> Maybe Char
-> (TM.Matcher -> P.LPdct)
-> OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand )
patternOption str mc f = C.OptSpec [str] so (C.OneArg g)
where
so = maybe [] (:[]) mc
g a1 = return $ \cs fty -> f <$> getMatcher a1 cs fty
account :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand )
account = C.OptSpec ["account"] "a" (C.OneArg f)
where
f a1 = return $ \cs fty -> fmap P.account (getMatcher a1 cs fty)
accountLevel :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand)
accountLevel = C.OptSpec ["account-level"] "" (C.TwoArg f)
where
f a1 a2 = return $ \cs fty ->
P.accountLevel <$> parseInt a1 <*> getMatcher a2 cs fty
accountAny :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand )
accountAny = patternOption "account-any" Nothing P.accountAny
payee :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand )
payee = patternOption "payee" (Just 'p') P.payee
tag :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand)
tag = patternOption "tag" (Just 't') P.tag
number :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand )
number = patternOption "number" (Just 'n') P.number
flag :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand)
flag = patternOption "flag" (Just 'f') P.flag
commodity :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand)
commodity = patternOption "commodity" (Just 'y') P.commodity
filename :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand )
filename = patternOption "filename" Nothing P.filename
postingMemo :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand)
postingMemo = patternOption "posting-memo" Nothing P.postingMemo
transactionMemo :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand)
transactionMemo = patternOption "transaction-memo"
Nothing P.transactionMemo
debit :: OptSpec Operand
debit = C.OptSpec ["debit"] [] (C.NoArg P.debit)
credit :: OptSpec Operand
credit = C.OptSpec ["credit"] [] (C.NoArg P.credit)
qtyOption :: OptSpec Operand
qtyOption = C.OptSpec ["qty"] "q" (C.TwoArg f)
where
f a1 a2 = do
qt <- parseQty a2
parseComparer a1 (flip P.qty qt)
parseQty a = case parse Pc.unquotedQtyRepWithSpaces "" (pack a) of
Left _ -> Left . ErrorMsg $ "failed to parse quantity"
Right g -> pure . L.toQty $ g
serialOption ::
(L.Posting -> Maybe L.Serial)
-> String
-> ( OptSpec Operand
, OptSpec Operand )
serialOption getSerial n = (osA, osD)
where
osA = C.OptSpec [n] []
(C.TwoArg (f n L.forward))
osD = let name = addPrefix "rev" n
in C.OptSpec [name] []
(C.TwoArg (f name L.backward))
f name getInt a1 a2 = do
num <- parseIntMA a2
let getPdct = E.compareByMaybe (pack . show $ num) (pack name) cmp
cmp l = case getSerial l of
Nothing -> Nothing
Just ser -> Just $ compare (getInt ser) num
parseComparer a1 getPdct
siblingSerialOption
:: String
-> (Int -> Ordering -> E.Pdct L.Posting)
-> (Int -> Ordering -> E.Pdct L.Posting)
-> ( OptSpec Operand
, OptSpec Operand )
siblingSerialOption n fFwd fBak = (osA, osD)
where
osA = C.OptSpec ["s-" ++ n] [] (C.TwoArg (f fFwd))
osD = let name = addPrefix "rev" n
in C.OptSpec ["s-" ++ name] [] (C.TwoArg (f fBak))
f getPdct a1 a2 = do
num <- parseIntMA a2
parseComparer a1 (getPdct num)
addPrefix :: String -> String -> String
addPrefix pre suf = pre ++ suf' where
suf' = case suf of
"" -> ""
x:xs -> toUpper x : xs
globalTransaction :: ( OptSpec Operand
, OptSpec Operand )
globalTransaction =
let f = fmap L.unGlobalTransaction . Q.globalTransaction
in serialOption f "globalTransaction"
globalPosting :: ( OptSpec Operand
, OptSpec Operand )
globalPosting =
let f = fmap L.unGlobalPosting . Q.globalPosting
in serialOption f "globalPosting"
filePosting :: ( OptSpec Operand
, OptSpec Operand )
filePosting =
let f = fmap L.unFilePosting . Q.filePosting
in serialOption f "filePosting"
fileTransaction :: ( OptSpec Operand
, OptSpec Operand )
fileTransaction =
let f = fmap L.unFileTransaction . Q.fileTransaction
in serialOption f "fileTransaction"
operandSpecs
:: L.DateTime
-> [OptSpec (CaseSensitive
-> MatcherFactory
-> Either Error Operand)]
operandSpecs dt =
[ fmap (const . const) (fmap Right date)
, fmap (const . const . pure) (current dt)
, account
, accountLevel
, accountAny
, payee
, tag
, number
, flag
, commodity
, postingMemo
, transactionMemo
, filename
, fmap (const . const . pure) debit
, fmap (const . const . pure) credit
, fmap (const . const) (fmap Right qtyOption)
, sAccount
, sAccountLevel
, sAccountAny
, sPayee
, sTag
, sNumber
, sFlag
, sCommodity
, sPostingMemo
, fmap (const . const . pure) sDebit
, fmap (const . const. pure) sCredit
, fmap (const . const) (fmap Right sQtyOption)
]
++ serialSpecs
serialSpecs :: [OptSpec (CaseSensitive
-> MatcherFactory
-> Either Error Operand)]
serialSpecs
= concat
$ [unDouble]
<*> [ globalTransaction, globalPosting,
filePosting, fileTransaction,
sGlobalPosting, sFilePosting,
sGlobalTransaction, sFileTransaction ]
unDouble
:: Functor f
=> (f a, f a)
-> [ f (x -> y -> Either Error a) ]
unDouble (o1, o2) =
[ fmap (const . const) (fmap Right o1)
, fmap (const . const) (fmap Right o2)]
data BadHeadTailError = BadHeadTailError Text
deriving Show
optHead :: OptSpec PostFilterFn
optHead = C.OptSpec ["head"] [] (C.OneArg f)
where
f a = do
num <- parseIntMA a
let g _ ii = ii < (ItemIndex num)
return g
optTail :: OptSpec PostFilterFn
optTail = C.OptSpec ["tail"] [] (C.OneArg f)
where
f a = do
num <- parseIntMA a
let g (ListLength len) (ItemIndex ii) = ii >= len num
return g
postFilterSpecs
:: ( OptSpec PostFilterFn , OptSpec PostFilterFn)
postFilterSpecs = (optHead, optTail)
parseInsensitive :: OptSpec CaseSensitive
parseInsensitive =
C.OptSpec ["case-insensitive"] ['i'] (C.NoArg Insensitive)
parseSensitive :: OptSpec CaseSensitive
parseSensitive =
C.OptSpec ["case-sensitive"] ['I'] (C.NoArg Sensitive)
within :: OptSpec MatcherFactory
within =
C.OptSpec ["within"] "w" . C.NoArg $ \c t ->
return (TM.within c t)
pcre :: OptSpec MatcherFactory
pcre = C.OptSpec ["pcre"] "r"
(C.NoArg (\cs x -> TM.pcre cs x))
exact :: OptSpec MatcherFactory
exact = C.OptSpec ["exact"] "x" . C.NoArg $ \c t ->
return (TM.exact c t)
matcherSelectSpecs :: [OptSpec MatcherFactory]
matcherSelectSpecs = [within, pcre, exact]
caseSelectSpecs :: [OptSpec CaseSensitive]
caseSelectSpecs = [parseInsensitive, parseSensitive]
open :: OptSpec (X.Token a)
open = C.OptSpec ["open"] "(" (C.NoArg X.openParen)
close :: OptSpec (X.Token a)
close = C.OptSpec ["close"] ")" (C.NoArg X.closeParen)
parseAnd :: OptSpec (X.Token a)
parseAnd = C.OptSpec ["and"] "A" (C.NoArg X.opAnd)
parseOr :: OptSpec (X.Token a)
parseOr = C.OptSpec ["or"] "O" (C.NoArg X.opOr)
parseNot :: OptSpec (X.Token a)
parseNot = C.OptSpec ["not"] "N" (C.NoArg X.opNot)
operatorSpecs :: [OptSpec (X.Token a)]
operatorSpecs =
[open, close, parseAnd, parseOr, parseNot]
parseInfix :: OptSpec X.ExprDesc
parseInfix = C.OptSpec ["infix"] "" (C.NoArg X.Infix)
parseRPN :: OptSpec X.ExprDesc
parseRPN = C.OptSpec ["rpn"] "" (C.NoArg X.RPN)
exprDesc :: [OptSpec X.ExprDesc]
exprDesc = [ parseInfix, parseRPN ]
showExpression :: OptSpec ()
showExpression = C.OptSpec ["show-expression"] "" (C.NoArg ())
verboseFilter :: OptSpec ()
verboseFilter = C.OptSpec ["verbose-filter"] "" (C.NoArg ())
sGlobalPosting :: ( OptSpec Operand
, OptSpec Operand )
sGlobalPosting =
siblingSerialOption "globalPosting"
PS.fwdGlobalPosting PS.backGlobalPosting
sFilePosting :: ( OptSpec Operand
, OptSpec Operand )
sFilePosting =
siblingSerialOption "filePosting"
PS.fwdFilePosting PS.backFilePosting
sGlobalTransaction :: ( OptSpec Operand
, OptSpec Operand )
sGlobalTransaction =
siblingSerialOption "globalTransaction"
PS.fwdGlobalTransaction PS.backGlobalTransaction
sFileTransaction :: ( OptSpec Operand
, OptSpec Operand )
sFileTransaction =
siblingSerialOption "filePosting"
PS.fwdFileTransaction PS.backFileTransaction
sAccount :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand )
sAccount = C.OptSpec ["s-account"] "" (C.OneArg f)
where
f a1 = return $ \cs fty -> fmap PS.account
$ getMatcher a1 cs fty
sAccountLevel :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand )
sAccountLevel = C.OptSpec ["s-account-level"] "" (C.TwoArg f)
where
f a1 a2 = return $ \cs fty
-> PS.accountLevel <$> parseInt a1 <*> getMatcher a2 cs fty
sAccountAny :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand )
sAccountAny = patternOption "s-account-any" Nothing PS.accountAny
sPayee :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand )
sPayee = patternOption "s-payee" (Just 'p') PS.payee
sTag :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand)
sTag = patternOption "s-tag" (Just 't') PS.tag
sNumber :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand )
sNumber = patternOption "s-number" Nothing PS.number
sFlag :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand)
sFlag = patternOption "s-flag" Nothing PS.flag
sCommodity :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand)
sCommodity = patternOption "s-commodity" Nothing PS.commodity
sPostingMemo :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Either Error Operand)
sPostingMemo = patternOption "s-posting-memo" Nothing PS.postingMemo
sDebit :: OptSpec Operand
sDebit = C.OptSpec ["s-debit"] [] (C.NoArg PS.debit)
sCredit :: OptSpec Operand
sCredit = C.OptSpec ["s-credit"] [] (C.NoArg PS.credit)
sQtyOption :: OptSpec Operand
sQtyOption = C.OptSpec ["s-qty"] [] (C.TwoArg f)
where
f a1 a2 = do
qt <- parseQty a2
parseComparer a1 (flip PS.qty qt)
parseQty a = case parse Pc.unquotedQtyRepWithSpaces "" (pack a) of
Left _ -> Left . ErrorMsg $ "could not parse quantity"
Right g -> pure . L.toQty $ g
version
:: V.Version
-> String
-> String
version v pn = unlines
[ pn ++ " version " ++ V.showVersion v
#ifdef incabal
, "using version " ++ V.showVersion PPL.version
#else
, "using testing version"
#endif
++ " of penny-lib"
]
output :: MA.OptSpec (X.Text -> IO ())
output = MA.OptSpec ["output"] "o" . MA.OneArg $ \s -> return $
if s == "-"
then TIO.putStr
else TIO.writeFile s
processOutput :: [X.Text -> IO ()] -> X.Text -> IO ()
processOutput ls x =
if null ls
then TIO.putStr x
else sequence_ . map ($ x) $ ls