module Penny.Cabin.Posts.Parser (parseOptions) where
import Control.Applicative ((<|>), (<$>), pure, many, (<*>))
import Control.Monad ((>=>))
import qualified Control.Monad.Exception.Synchronous as Ex
import Data.Char (toLower)
import qualified Data.Foldable as F
import qualified System.Console.MultiArg.Combinator as C
import System.Console.MultiArg.Prim (Parser)
import qualified Penny.Cabin.Chunk as CC
import qualified Penny.Cabin.Colors as PC
import qualified Penny.Cabin.Posts.Fields as Fl
import qualified Penny.Cabin.Posts.Options as Op
import qualified Penny.Cabin.Colors.DarkBackground as DB
import qualified Penny.Cabin.Colors.LightBackground as LB
import qualified Penny.Cabin.Options as CO
import qualified Penny.Liberty as Ly
import qualified Penny.Liberty.Expressions as Exp
import qualified Penny.Lincoln as L
import qualified Penny.Shield as S
data Error = BadColorName String
| BadBackgroundArg String
| BadWidthArg String
| NoMatchingFieldName
| MultipleMatchingFieldNames [String]
| LibertyError Ly.Error
| BadNumber String
| BadComparator String
deriving Show
parseOptions ::
Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T)
parseOptions = f <$> many parseOption where
f ls =
let g rt op =
let ls' = map (\fn -> fn rt) ls
in (foldl (>=>) return ls') op
in g
parseOption ::
Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T)
parseOption =
operand
<|> mkTwoArg boxFilters
<|> mkTwoArg postFilter
<|> mkTwoArg matcherSelect
<|> mkTwoArg caseSelect
<|> mkTwoArg operator
<|> color
<|> mkTwoArg background
<|> mkTwoArg width
<|> mkTwoArg showField
<|> mkTwoArg hideField
<|> mkTwoArg showAllFields
<|> mkTwoArg hideAllFields
<|> mkTwoArg showZeroBalances
<|> mkTwoArg hideZeroBalances
where
mkTwoArg p = do
f <- p
return (\_ o -> f o)
operand :: Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T)
operand = f <$> Ly.parseOperand
where
f lyFn rt op =
let dtz = Op.timeZone op
rg = Op.radGroup op
dt = S.currentTime rt
cs = Op.sensitive op
fty = Op.factory op
in case lyFn dt dtz rg cs fty of
Ex.Exception e -> Ex.throw . LibertyError $ e
Ex.Success (Exp.Operand g) ->
let g' = g . L.boxPostFam
ts' = Op.tokens op ++ [Exp.TokOperand g']
in return op { Op.tokens = ts' }
optBoxSerial ::
[String]
-> [Char]
-> (Ly.LibertyMeta -> Int)
-> Parser (Op.T -> Ex.Exceptional Error Op.T)
optBoxSerial ls ss f = parseOpt ls ss (C.TwoArg g)
where
g a1 a2 op = do
cmp <- Ex.fromMaybe (BadComparator a1) (Ly.parseComparer a1)
i <- parseInt a2
let h box =
let ser = f . L.boxMeta $ box
in ser `cmp` i
tok = Exp.TokOperand h
return op { Op.tokens = Op.tokens op ++ [tok] }
optFilteredNum :: Parser (Op.T -> Ex.Exceptional Error Op.T)
optFilteredNum = optBoxSerial ["filtered"] "" f
where
f = L.forward . Ly.unFilteredNum . Ly.filteredNum
optRevFilteredNum :: Parser (Op.T -> Ex.Exceptional Error Op.T)
optRevFilteredNum = optBoxSerial ["revFiltered"] "" f
where
f = L.backward . Ly.unFilteredNum . Ly.filteredNum
optSortedNum :: Parser (Op.T -> Ex.Exceptional Error Op.T)
optSortedNum = optBoxSerial ["sorted"] "" f
where
f = L.forward . Ly.unSortedNum . Ly.sortedNum
optRevSortedNum :: Parser (Op.T -> Ex.Exceptional Error Op.T)
optRevSortedNum = optBoxSerial ["revSorted"] "" f
where
f = L.backward . Ly.unSortedNum . Ly.sortedNum
parseInt :: String -> Ex.Exceptional Error Int
parseInt s = case reads s of
(i, ""):[] -> return i
_ -> Ex.throw . BadNumber $ s
boxFilters :: Parser (Op.T -> Ex.Exceptional Error Op.T)
boxFilters =
optFilteredNum
<|> optRevFilteredNum
<|> optSortedNum
<|> optRevSortedNum
postFilter :: Parser (Op.T -> Ex.Exceptional Error Op.T)
postFilter = f <$> Ly.parsePostFilter
where
f ex op =
case ex of
Ex.Exception e -> Ex.throw . LibertyError $ e
Ex.Success pf ->
return op { Op.postFilter = Op.postFilter op ++ [pf] }
matcherSelect :: Parser (Op.T -> Ex.Exceptional Error Op.T)
matcherSelect = f <$> Ly.parseMatcherSelect
where
f mf op = return op { Op.factory = mf }
caseSelect :: Parser (Op.T -> Ex.Exceptional Error Op.T)
caseSelect = f <$> Ly.parseCaseSelect
where
f cs op = return op { Op.sensitive = cs }
operator :: Parser (Op.T -> Ex.Exceptional Error Op.T)
operator = f <$> Ly.parseOperator
where
f oo op = return op { Op.tokens = Op.tokens op ++ [oo] }
parseOpt :: [String] -> [Char] -> C.ArgSpec a -> Parser a
parseOpt ss cs a = C.parseOption [C.OptSpec ss cs a]
color :: Parser (S.Runtime -> Op.T -> Ex.Exceptional Error Op.T)
color = parseOpt ["color"] "" (C.OneArg f)
where
f a1 rt op = case pickColorArg rt a1 of
Nothing -> Ex.throw . BadColorName $ a1
Just c -> return (op { Op.colorPref = c })
pickColorArg :: S.Runtime -> String -> Maybe CC.Colors
pickColorArg rt t
| t == "yes" = Just CC.Colors8
| t == "no" = Just CC.Colors0
| t == "256" = Just CC.Colors256
| t == "auto" = Just . CO.maxCapableColors $ rt
| otherwise = Nothing
pickBackgroundArg :: String -> Maybe (PC.DrCrColors, PC.BaseColors)
pickBackgroundArg t
| t == "light" = Just (LB.drCrColors, LB.baseColors)
| t == "dark" = Just (DB.drCrColors, DB.baseColors)
| otherwise = Nothing
background :: Parser (Op.T -> Ex.Exceptional Error Op.T)
background = parseOpt ["background"] "" (C.OneArg f)
where
f a1 op = case pickBackgroundArg a1 of
Nothing -> Ex.throw . BadBackgroundArg $ a1
Just (dc, bc) -> return (op { Op.drCrColors = dc
, Op.baseColors = bc } )
width :: Parser (Op.T -> Ex.Exceptional Error Op.T)
width = parseOpt ["width"] "" (C.OneArg f)
where
f a1 op = case reads a1 of
(i, ""):[] -> return (op { Op.width = Op.ReportWidth i })
_ -> Ex.throw . BadWidthArg $ a1
showField :: Parser (Op.T -> Ex.Exceptional Error Op.T)
showField = parseOpt ["show"] "" (C.OneArg f)
where
f a1 op = do
fl <- parseField a1
let newFl = fieldOn (Op.fields op) fl
return op { Op.fields = newFl }
hideField :: Parser (Op.T -> Ex.Exceptional Error Op.T)
hideField = parseOpt ["hide"] "" (C.OneArg f)
where
f a1 op = do
fl <- parseField a1
let newFl = fieldOff (Op.fields op) fl
return op { Op.fields = newFl }
showAllFields :: Parser (Op.T -> Ex.Exceptional a Op.T)
showAllFields = parseOpt ["show-all"] "" (C.NoArg f)
where
f op = return (op {Op.fields = pure True})
hideAllFields :: Parser (Op.T -> Ex.Exceptional a Op.T)
hideAllFields = parseOpt ["hide-all"] "" (C.NoArg f)
where
f op = return (op {Op.fields = pure False})
showZeroBalances :: Parser (Op.T -> Ex.Exceptional a Op.T)
showZeroBalances = parseOpt ["show-zero-balances"] "" (C.NoArg f)
where
f op =
return (op {Op.showZeroBalances = CO.ShowZeroBalances True })
hideZeroBalances :: Parser (Op.T -> Ex.Exceptional a Op.T)
hideZeroBalances = parseOpt ["hide-zero-balances"] "" (C.NoArg f)
where
f op =
return (op {Op.showZeroBalances = CO.ShowZeroBalances False })
fieldOn ::
Fl.T Bool
-> Fl.T Bool
-> Fl.T Bool
fieldOn old new = (||) <$> old <*> new
fieldOff ::
Fl.T Bool
-> Fl.T Bool
-> Fl.T Bool
fieldOff old new = f <$> old <*> new
where
f o False = o
f _ True = False
parseField :: String -> Ex.Exceptional Error (Fl.T Bool)
parseField str =
let lower = map toLower str
checkField s =
if (map toLower s) == lower
then (s, True)
else (s, False)
flds = checkField <$> fieldNames
in checkFields flds
checkFields :: Fl.T (String, Bool) -> Ex.Exceptional Error (Fl.T Bool)
checkFields fs =
let f (s, b) ls = if b then s:ls else ls
in case F.foldr f [] fs of
[] -> Ex.throw NoMatchingFieldName
_:[] -> return (snd <$> fs)
ls -> Ex.throw . MultipleMatchingFieldNames $ ls
fieldNames :: Fl.T String
fieldNames = Fl.T {
Fl.globalTransaction = "globalTransaction"
, Fl.revGlobalTransaction = "revGlobalTransaction"
, Fl.globalPosting = "globalPosting"
, Fl.revGlobalPosting = "revGlobalPosting"
, Fl.fileTransaction = "fileTransaction"
, Fl.revFileTransaction = "revFileTransaction"
, Fl.filePosting = "filePosting"
, Fl.revFilePosting = "revFilePosting"
, Fl.filtered = "filtered"
, Fl.revFiltered = "revFiltered"
, Fl.sorted = "sorted"
, Fl.revSorted = "revSorted"
, Fl.visible = "visible"
, Fl.revVisible = "revVisible"
, Fl.lineNum = "lineNum"
, Fl.date = "date"
, Fl.flag = "flag"
, Fl.number = "number"
, Fl.payee = "payee"
, Fl.account = "account"
, Fl.postingDrCr = "postingDrCr"
, Fl.postingCmdty = "postingCmdty"
, Fl.postingQty = "postingQty"
, Fl.totalDrCr = "totalDrCr"
, Fl.totalCmdty = "totalCmdty"
, Fl.totalQty = "totalQty"
, Fl.tags = "tags"
, Fl.memo = "memo"
, Fl.filename = "filename" }