module Penny.Zinc.Parser.Filter (
parseFilter
, Error(LibertyError, TokenParseError)
, NeedsHelp(NeedsHelp)
, Result(Result, resultFactory, resultSensitive, sorterFilterer)
) where
import Control.Applicative ((<|>), (<$>), Applicative, pure, many)
import Control.Monad ((>=>))
import qualified Control.Monad.Exception.Synchronous as Ex
import Data.Monoid (mempty, mappend)
import Data.Text (Text)
import qualified Text.Matchers.Text as M
import qualified System.Console.MultiArg.Combinator as C
import System.Console.MultiArg.Prim (Parser)
import qualified Penny.Copper as Cop
import qualified Penny.Lincoln as L
import qualified Penny.Liberty as Ly
import qualified Penny.Liberty.Expressions as X
import qualified Penny.Zinc.Parser.Defaults as D
import qualified Penny.Zinc.Parser.Defaults as Defaults
parseFilter ::
Defaults.T
-> Parser (Ex.Exceptional Error (Either NeedsHelp Result))
parseFilter d = fmap f (many parser) where
f ls =
let k = foldl (>=>) return ls
in case k (newState d) of
Ex.Success st' ->
if help st'
then return . Left $ NeedsHelp
else
case Ly.parsePredicate . tokens $ st' of
Nothing -> Ex.throw TokenParseError
Just pdct ->
let fn = Ly.xactionsToFiltered pdct
(postFilter st') (orderer st')
r = Result { resultFactory = factory st'
, resultSensitive = sensitive st'
, sorterFilterer = fn }
in return . Right $ r
Ex.Exception e -> Ex.Exception e
data Error = LibertyError Ly.Error
| TokenParseError
deriving Show
data NeedsHelp = NeedsHelp
deriving Show
data Result =
Result { resultFactory :: M.CaseSensitive
-> Text -> Ex.Exceptional Text (Text -> Bool)
, resultSensitive :: M.CaseSensitive
, sorterFilterer :: [L.Transaction] -> [L.Box Ly.LibertyMeta]
}
data State =
State { sensitive :: M.CaseSensitive
, factory :: M.CaseSensitive
-> Text -> Ex.Exceptional Text (Text -> Bool)
, tokens :: [X.Token (L.PostFam -> Bool)]
, postFilter :: [Ly.PostFilterFn]
, orderer :: Ly.Orderer
, help :: Bool
, currentTime :: L.DateTime
, defaultTimeZone :: Cop.DefaultTimeZone
, radGroup :: Cop.RadGroup }
newState ::
Defaults.T
-> State
newState d =
State { sensitive = D.sensitive d
, factory = D.factory d
, tokens = []
, postFilter = []
, orderer = mempty
, help = False
, currentTime = D.currentTime d
, defaultTimeZone = D.defaultTimeZone d
, radGroup = D.radGroup d }
parser :: Parser (State -> Ex.Exceptional Error State)
parser =
operand
<|> parsePostFilter
<|> impurify parseMatcherSelect
<|> impurify parseCaseSelect
<|> impurify parseOperator
<|> parseSort
<|> impurify parseHelp
option :: [String] -> [Char] -> C.ArgSpec a -> Parser a
option ss cs a = C.parseOption [C.OptSpec ss cs a]
operand :: Parser (State -> Ex.Exceptional Error State)
operand = f <$> Ly.parseOperand
where
f lyFn =
let g st =
let r = lyFn (currentTime st) (defaultTimeZone st)
(radGroup st) (sensitive st) (factory st)
in case r of
Ex.Exception e -> Ex.throw . LibertyError $ e
Ex.Success (X.Operand o) ->
let tok' = tokens st ++ [X.TokOperand o]
in return st { tokens = tok' }
in g
parsePostFilter :: Parser (State -> Ex.Exceptional Error State)
parsePostFilter = f <$> Ly.parsePostFilter
where
f lyResult =
let g st = case lyResult of
Ex.Exception e -> Ex.throw . LibertyError $ e
Ex.Success pf ->
let ls' = postFilter st ++ [pf]
in return st { postFilter = ls' }
in g
impurify ::
(Functor f, Applicative a)
=> f (b -> b)
-> f (b -> a b)
impurify = fmap (pure .)
parseMatcherSelect :: Parser (State -> State)
parseMatcherSelect = f <$> Ly.parseMatcherSelect
where
f fty = g
where
g st = st { factory = fty }
parseCaseSelect :: Parser (State -> State)
parseCaseSelect = f <$> Ly.parseCaseSelect
where
f sel = g
where
g st = st { sensitive = sel }
parseOperator :: Parser (State -> State)
parseOperator = f <$> Ly.parseOperator
where
f tok = g
where
g st = st { tokens = tokens st ++ [tok] }
parseSort :: Parser (State -> Ex.Exceptional Error State)
parseSort = f <$> Ly.parseSort
where
f exOrd = g
where
g st = case exOrd of
Ex.Exception e -> Ex.throw . LibertyError $ e
Ex.Success o ->
return st { orderer = mappend o (orderer st) }
parseHelp :: Parser (State -> State)
parseHelp = option ["help"] ['h'] (C.NoArg f)
where
f st = st { help = True }