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,
parseInfix,
parseRPN,
exprDesc,
showExpression,
verboseFilter,
Operand,
operandSpecs,
postFilterSpecs,
matcherSelectSpecs,
caseSelectSpecs,
operatorSpecs,
Error
) where
import Control.Applicative ((<*>), (<$>), pure, Applicative)
import qualified Control.Monad.Exception.Synchronous as Ex
import Data.Char (toUpper)
import Data.Maybe (mapMaybe)
import Data.Monoid ((<>))
import Data.List (sortBy)
import Data.Text (Text, pack)
import qualified Data.Time as Time
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 Penny.Lincoln.Family.Child (child, parent)
import qualified Penny.Lincoln.Predicates as P
import qualified Penny.Steel.Pdct as E
import qualified Penny.Lincoln as L
import qualified Penny.Steel.Chunk as C
import qualified Penny.Steel.Expressions as X
import Text.Matchers (
CaseSensitive(Sensitive, Insensitive))
import qualified Text.Matchers as TM
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]
-> Ex.Exceptional Error (E.Pdct a)
parsePredicate d ls = case ls of
[] -> return E.always
_ -> X.parseExpression d ls
xactionsToFiltered ::
P.LPdct
-> [PostFilterFn]
-> (L.PostFam -> L.PostFam -> Ordering)
-> [L.Transaction]
-> ([C.Chunk], [L.Box LibertyMeta])
xactionsToFiltered pdct postFilts s txns =
let pdcts = map (makeLabeledPdct pdct) pfs
evaluator subj pd = E.evaluate indentAmt True subj 0 pd
pairMaybes = zipWith evaluator pfs pdcts
pairs = mapMaybe rmMaybe pairMaybes
rmMaybe (mayB, x) = case mayB of
Nothing -> Nothing
Just b -> Just (b, x)
pfs = concatMap L.postFam txns
txt = concatMap snd pairs
filtered = map snd . filter fst $ zipWith zipper pairs pfs
zipper (bool, _) pf = (bool, pf)
resultLs = addSortedNum
. processPostFilters postFilts
. sortBy (sorter s)
. addFilteredNum
. map toBox
$ filtered
in (txt, resultLs)
makeLabeledPdct :: E.Pdct L.PostFam -> L.PostFam -> E.Pdct L.PostFam
makeLabeledPdct pd pf = E.rename f pd
where
f old = old <> " - " <> L.display pf
indentAmt :: E.IndentAmt
indentAmt = 4
toBox :: L.PostFam -> L.Box ()
toBox = L.Box ()
addFilteredNum :: [L.Box a] -> [L.Box FilteredNum]
addFilteredNum = L.serialItems f where
f ser = fmap (const (FilteredNum ser))
sorter :: (L.PostFam -> L.PostFam -> Ordering)
-> L.Box a
-> L.Box b
-> Ordering
sorter f b1 b2 = f (L.boxPostFam b1) (L.boxPostFam b2)
addSortedNum ::
[L.Box FilteredNum]
-> [L.Box LibertyMeta]
addSortedNum = L.serialItems f where
f ser = fmap g where
g filtNum = LibertyMeta filtNum (SortedNum ser)
type MatcherFactory =
CaseSensitive
-> Text
-> Ex.Exceptional 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
-> Ex.Exceptional Error TM.Matcher
getMatcher s cs f
= Ex.mapException mkError
$ f cs (pack s)
where
mkError eMsg = "bad pattern: \"" <> pack s <> " - " <> eMsg
<> "\n"
parseComparer :: String -> Ex.Exceptional Error P.Comp
parseComparer t
| t == "<" = return P.DLT
| t == "<=" = return P.DLTEQ
| t == "==" = return P.DEQ
| t == "=" = return P.DEQ
| t == ">" = return P.DGT
| t == ">=" = return P.DGTEQ
| t == "/=" = return P.DNE
| t == "!=" = return P.DNE
| otherwise = Ex.throw msg
where
msg = "bad comparer: " <> pack t <> "\n"
parseDate :: String -> Ex.Exceptional Error Time.UTCTime
parseDate arg =
Ex.mapExceptional err L.toUTC
. Ex.fromEither
. parse Pc.dateTime ""
. pack
$ arg
where
err msg = "bad date: \"" <> pack arg <> "\" - " <> (pack . show $ msg)
type Operand = E.Pdct L.PostFam
date :: OptSpec (Ex.Exceptional Error Operand)
date = C.OptSpec ["date"] ['d'] (C.TwoArg f)
where
f a1 a2 = P.date <$> parseComparer a1 <*> parseDate a2
current :: L.DateTime -> OptSpec Operand
current dt = C.OptSpec ["current"] [] (C.NoArg f)
where
f = P.date P.DLTEQ (L.toUTC dt)
parseInt :: String -> Ex.Exceptional Error Int
parseInt t =
case reads t of
((i, ""):[]) -> return i
_ -> Ex.throw $ "could not parse integer: \"" <> pack t <> "\"\n"
patternOption ::
String
-> Maybe Char
-> (TM.Matcher -> P.LPdct)
-> OptSpec ( CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand )
patternOption str mc f = C.OptSpec [str] so (C.OneArg g)
where
so = maybe [] (:[]) mc
g a1 cs fty = f <$> getMatcher a1 cs fty
account :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand )
account = C.OptSpec ["account"] "a" (C.OneArg f)
where
f a1 cs fty
= fmap P.account
$ getMatcher a1 cs fty
accountLevel :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand)
accountLevel = C.OptSpec ["account-level"] "" (C.TwoArg f)
where
f a1 a2 cs fty
= P.accountLevel <$> parseInt a1 <*> getMatcher a2 cs fty
accountAny :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand )
accountAny = patternOption "account-any" Nothing P.accountAny
payee :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand )
payee = patternOption "payee" (Just 'p') P.payee
tag :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand)
tag = patternOption "tag" (Just 't') P.tag
number :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand )
number = patternOption "number" Nothing P.number
flag :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand)
flag = patternOption "flag" Nothing P.flag
commodity :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand)
commodity = patternOption "commodity" Nothing P.commodity
postingMemo :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand)
postingMemo = patternOption "posting-memo" Nothing P.postingMemo
transactionMemo :: OptSpec ( CaseSensitive
-> MatcherFactory
-> Ex.Exceptional 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 (Ex.Exceptional Error Operand)
qtyOption = C.OptSpec ["qty"] [] (C.TwoArg f)
where
f a1 a2 = P.qty <$> parseComparer a1 <*> parseQty a2
parseQty a = case parse Pc.quantity "" (pack a) of
Left e -> Ex.throw $ "could not parse quantity: "
<> pack a <> " - "
<> (pack . show $ e)
Right g -> pure g
serialOption ::
(L.PostFam -> Maybe L.Serial)
-> String
-> ( OptSpec (Ex.Exceptional Error Operand)
, OptSpec (Ex.Exceptional Error Operand) )
serialOption getSerial n = (osA, osD)
where
osA = C.OptSpec [n] []
(C.TwoArg (f L.forward))
osD = C.OptSpec [addPrefix "rev" n] []
(C.TwoArg (f L.backward))
f getInt a1 a2 = do
cmp <- parseComparer a1
num <- parseInt a2
let op pf = case getSerial pf of
Nothing -> False
Just ser -> getInt ser `cmpFn` num
(cmpDesc, cmpFn) = P.descComp cmp
desc = pack n <> " is " <> cmpDesc <> " " <> (pack . show $ num)
return (E.operand desc op)
addPrefix :: String -> String -> String
addPrefix pre suf = pre ++ suf' where
suf' = case suf of
"" -> ""
x:xs -> toUpper x : xs
globalTransaction :: ( OptSpec (Ex.Exceptional Error Operand)
, OptSpec (Ex.Exceptional Error Operand) )
globalTransaction =
let f = fmap L.unGlobalTransaction
. L.tGlobalTransaction
. parent
. L.unPostFam
in serialOption f "globalTransaction"
globalPosting :: ( OptSpec (Ex.Exceptional Error Operand)
, OptSpec (Ex.Exceptional Error Operand) )
globalPosting =
let f = fmap L.unGlobalPosting
. L.pGlobalPosting
. child
. L.unPostFam
in serialOption f "globalPosting"
filePosting :: ( OptSpec (Ex.Exceptional Error Operand)
, OptSpec (Ex.Exceptional Error Operand) )
filePosting =
let f = fmap L.unFilePosting
. L.pFilePosting
. child
. L.unPostFam
in serialOption f "filePosting"
fileTransaction :: ( OptSpec (Ex.Exceptional Error Operand)
, OptSpec (Ex.Exceptional Error Operand) )
fileTransaction =
let f = fmap L.unFileTransaction
. L.tFileTransaction
. parent
. L.unPostFam
in serialOption f "fileTransaction"
operandSpecs
:: L.DateTime
-> [OptSpec (CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand)]
operandSpecs dt =
[ fmap (const . const) date
, fmap (const . const . pure) (current dt)
, account
, accountLevel
, accountAny
, payee
, tag
, number
, flag
, commodity
, postingMemo
, transactionMemo
, fmap (const . const . pure) debit
, fmap (const . const . pure) credit
, fmap (const . const) qtyOption
]
++ serialSpecs
serialSpecs :: [OptSpec (CaseSensitive
-> MatcherFactory
-> Ex.Exceptional Error Operand)]
serialSpecs
= concat
$ [unDouble]
<*> [ globalTransaction, globalPosting,
filePosting, fileTransaction ]
unDouble
:: Functor f
=> (f (Ex.Exceptional Error a),
f (Ex.Exceptional Error a ))
-> [ f (x -> y -> Ex.Exceptional Error a) ]
unDouble (o1, o2) = [fmap (const . const) o1, fmap (const . const) o2]
data BadHeadTailError = BadHeadTailError Text
deriving Show
optHead :: OptSpec (Ex.Exceptional Error PostFilterFn)
optHead = C.OptSpec ["head"] [] (C.OneArg f)
where
f a = do
num <- parseInt a
let g _ ii = ii < (ItemIndex num)
return g
optTail :: OptSpec (Ex.Exceptional Error PostFilterFn)
optTail = C.OptSpec ["tail"] [] (C.OneArg f)
where
f a = do
num <- parseInt a
let g (ListLength len) (ItemIndex ii) = ii >= len num
return g
postFilterSpecs :: ( OptSpec (Ex.Exceptional Error PostFilterFn)
, OptSpec (Ex.Exceptional Error PostFilterFn) )
postFilterSpecs = (optHead, optTail)
noArg :: a -> String -> OptSpec a
noArg a s = C.OptSpec [s] "" (C.NoArg a)
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 = noArg (\c t -> return (TM.within c t)) "within"
pcre :: OptSpec MatcherFactory
pcre = noArg TM.pcre "pcre"
posix :: OptSpec MatcherFactory
posix = noArg TM.tdfa "posix"
exact :: OptSpec MatcherFactory
exact = noArg (\c t -> return (TM.exact c t)) "exact"
matcherSelectSpecs :: [OptSpec MatcherFactory]
matcherSelectSpecs = [within, pcre, posix, exact]
caseSelectSpecs :: [OptSpec CaseSensitive]
caseSelectSpecs = [parseInsensitive, parseSensitive]
open :: OptSpec (X.Token a)
open = noArg X.openParen "open"
close :: OptSpec (X.Token a)
close = noArg X.closeParen "close"
parseAnd :: OptSpec (X.Token a)
parseAnd = noArg X.opAnd "and"
parseOr :: OptSpec (X.Token a)
parseOr = noArg X.opOr "or"
parseNot :: OptSpec (X.Token a)
parseNot = noArg X.opNot "not"
operatorSpecs :: [OptSpec (X.Token a)]
operatorSpecs =
[open, close, parseAnd, parseOr, parseNot]
parseInfix :: OptSpec X.ExprDesc
parseInfix = noArg X.Infix "infix"
parseRPN :: OptSpec X.ExprDesc
parseRPN = noArg X.RPN "rpn"
exprDesc :: [OptSpec X.ExprDesc]
exprDesc = [ parseInfix, parseRPN ]
showExpression :: OptSpec ()
showExpression = noArg () "show-expression"
verboseFilter :: OptSpec ()
verboseFilter = noArg () "verbose-filter"