module Penny.Cabin.Posts.Parser (State(..),
allSpecs) where
import Control.Applicative ((<$>), pure, (<*>),
Applicative)
import qualified Control.Monad.Exception.Synchronous as Ex
import Data.Char (toLower)
import qualified Data.Foldable as Fdbl
import qualified System.Console.MultiArg.Combinator as C
import qualified System.Console.MultiArg as MA
import qualified Penny.Cabin.Parsers as P
import qualified Penny.Cabin.Posts.Fields as F
import qualified Penny.Cabin.Posts.Types as Ty
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
import qualified Text.Matchers.Text as M
data State = State
{ sensitive :: M.CaseSensitive
, factory :: L.Factory
, tokens :: [Ly.Token (L.Box Ly.LibertyMeta -> Bool)]
, postFilter :: [Ly.PostFilterFn]
, fields :: F.Fields Bool
, width :: Ty.ReportWidth
, showZeroBalances :: CO.ShowZeroBalances
, showHelp :: Bool
}
allSpecs
:: S.Runtime -> [MA.OptSpec (State -> Ex.Exceptional String State)]
allSpecs rt =
operand rt
++ boxFilters
++ parsePostFilter
++ matcherSelect
++ caseSelect
++ operator
++ [ parseWidth
, showField
, hideField
, showAllFields
, hideAllFields
, parseZeroBalances
, optHelp
]
operand
:: S.Runtime
-> [MA.OptSpec (State -> Ex.Exceptional String State)]
operand rt = map (fmap f) (Ly.operandSpecs (S.currentTime rt))
where
f lyFn st = do
let cs = sensitive st
fty = factory st
(Exp.Operand g) <- lyFn cs fty
let g' = g . L.boxPostFam
ts' = tokens st ++ [Exp.TokOperand g']
return $ st { tokens = ts' }
optBoxSerial ::
[String]
-> [Char]
-> (Ly.LibertyMeta -> Int)
-> C.OptSpec (State -> Ex.Exceptional String State)
optBoxSerial ls ss f = C.OptSpec ls ss (C.TwoArg g)
where
g a1 a2 st = do
cmp <- Ly.parseComparer a1
i <- Ly.parseInt a2
let h box =
let ser = f . L.boxMeta $ box
in ser `cmp` i
tok = Exp.TokOperand h
return $ st { tokens = tokens st ++ [tok] }
optFilteredNum :: C.OptSpec (State -> Ex.Exceptional String State)
optFilteredNum = optBoxSerial ["filtered"] "" f
where
f = L.forward . Ly.unFilteredNum . Ly.filteredNum
optRevFilteredNum :: C.OptSpec (State -> Ex.Exceptional String State)
optRevFilteredNum = optBoxSerial ["revFiltered"] "" f
where
f = L.backward . Ly.unFilteredNum . Ly.filteredNum
optSortedNum :: C.OptSpec (State -> Ex.Exceptional String State)
optSortedNum = optBoxSerial ["sorted"] "" f
where
f = L.forward . Ly.unSortedNum . Ly.sortedNum
optRevSortedNum :: C.OptSpec (State -> Ex.Exceptional String State)
optRevSortedNum = optBoxSerial ["revSorted"] "" f
where
f = L.backward . Ly.unSortedNum . Ly.sortedNum
boxFilters :: [C.OptSpec (State -> Ex.Exceptional String State)]
boxFilters =
[ optFilteredNum
, optRevFilteredNum
, optSortedNum
, optRevSortedNum
]
parsePostFilter :: [C.OptSpec (State -> Ex.Exceptional String State)]
parsePostFilter = [fmap f optH, fmap f optT]
where
(optH, optT) = Ly.postFilterSpecs
f exc = case exc of
Ex.Exception s -> const $ Ex.throw s
Ex.Success pf ->
let g st = return $ st { postFilter = postFilter st ++ [pf] }
in g
matcherSelect :: Applicative f => [C.OptSpec (State -> f State)]
matcherSelect = map (fmap f) Ly.matcherSelectSpecs
where
f mf st = pure $ st { factory = mf }
caseSelect :: Applicative f => [C.OptSpec (State -> f State)]
caseSelect = map (fmap f) Ly.caseSelectSpecs
where
f cs st = pure $ st { sensitive = cs }
operator :: Applicative f => [C.OptSpec (State -> f State)]
operator = map (fmap f) Ly.operatorSpecs
where
f oo st = pure $ st { tokens = tokens st ++ [oo] }
parseWidth :: C.OptSpec (State -> Ex.Exceptional String State)
parseWidth = C.OptSpec ["width"] "" (C.OneArg f)
where
f a1 st = do
i <- Ly.parseInt a1
return $ st { width = Ty.ReportWidth i }
parseField :: String -> Ex.Exceptional String (F.Fields Bool)
parseField str =
let lower = map toLower str
checkField s =
if (map toLower s) == lower
then (s, True)
else (s, False)
flds = checkField <$> F.fieldNames
in checkFields flds
fieldOn ::
F.Fields Bool
-> F.Fields Bool
-> F.Fields Bool
fieldOn old new = (||) <$> old <*> new
fieldOff ::
F.Fields Bool
-> F.Fields Bool
-> F.Fields Bool
fieldOff old new = f <$> old <*> new
where
f o False = o
f _ True = False
showField :: C.OptSpec (State -> Ex.Exceptional String State)
showField = C.OptSpec ["show"] "" (C.OneArg f)
where
f a1 st = do
fl <- parseField a1
let newFl = fieldOn (fields st) fl
return $ st { fields = newFl }
hideField :: C.OptSpec (State -> Ex.Exceptional String State)
hideField = C.OptSpec ["hide"] "" (C.OneArg f)
where
f a1 st = do
fl <- parseField a1
let newFl = fieldOff (fields st) fl
return $ st { fields = newFl }
showAllFields :: Applicative f => C.OptSpec (State -> f State)
showAllFields = C.OptSpec ["show-all"] "" (C.NoArg f)
where
f st = pure $ st {fields = pure True}
hideAllFields :: Applicative f => C.OptSpec (State -> f State)
hideAllFields = C.OptSpec ["hide-all"] "" (C.NoArg f)
where
f st = pure $ st {fields = pure False}
optHelp :: Applicative f => C.OptSpec (State -> f State)
optHelp = fmap f P.help
where
f _ st = pure $ st { showHelp = True }
parseZeroBalances :: Applicative f => C.OptSpec (State -> f State)
parseZeroBalances = fmap f P.zeroBalances
where
f szb st = pure $ st { showZeroBalances = szb }
checkFields ::
F.Fields (String, Bool)
-> Ex.Exceptional String (F.Fields Bool)
checkFields fs =
let f (s, b) ls = if b then s:ls else ls
in case Fdbl.foldr f [] fs of
[] -> Ex.throw "no matching field names"
_:[] -> return (snd <$> fs)
_ -> Ex.throw "multiple matching field names"