{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hcompta.Filter.Read where import Control.Applicative ((<$>), (<*)) import Control.Exception (assert) import Control.Monad (Monad(..), liftM, join, when, (=<<), (>=>), void, forM) import Data.Bool import Data.Char import Data.Data import Data.Either (Either(..)) import Data.Eq (Eq(..)) import qualified Data.Foldable import Data.Foldable (Foldable(..)) import Data.Functor (Functor(..)) import Data.Functor.Identity (Identity) import Data.List ((++), concat, map, reverse) import Data.Maybe (Maybe(..), catMaybes) import Data.Ord (Ord(..)) import Data.String (String, fromString) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Time.Clock as Time import Data.Typeable () import Prelude (($), (.), Integer, IO, Num(..), undefined) import qualified Text.Parsec.Expr as R import qualified Text.Parsec as R hiding ( char , anyChar , crlf , newline , noneOf , oneOf , satisfy , space , spaces , string ) import Text.Parsec (Stream, ParsecT, (<|>), ()) import Text.Show (Show(..)) -- import qualified Hcompta.Amount as Amount import Hcompta.Date (Date) import qualified Hcompta.Date as Date import Hcompta.Filter import qualified Hcompta.Filter as Filter import qualified Hcompta.Filter.Amount as Filter.Amount import qualified Hcompta.Filter.Amount.Read as Amount.Read import qualified Hcompta.Filter.Date.Read as Date.Read import Hcompta.Lib.Interval (Interval) import qualified Hcompta.Lib.Interval as Interval import qualified Hcompta.Lib.Parsec as R import qualified Hcompta.Lib.Regex as Regex import Hcompta.Posting (Posting(..)) -- import Hcompta.Polarize -- import qualified Hcompta.Quantity as Quantity import qualified Hcompta.Unit as Unit -- * Type 'Context' data Context = Context { context_date :: Date } deriving (Data, Eq, Show, Typeable) context :: Context context = Context { context_date = Date.nil } -- * Type 'Error' data Error = Error_Unknown | Error_Filter_Date Date.Read.Error | Error_Filter_Date_Interval (Integer, Integer) deriving (Show) -- * Read read :: ( Stream s (R.Error_State Error Identity) Char , Show t ) => ParsecT s Context (R.Error_State Error Identity) (Filter_Bool t) -> s -> IO (Either [R.Error Error] (Filter_Bool t)) read t s = do context_date <- Time.getCurrentTime return $ R.runParser_with_Error t context{context_date} "" s -- * Read 'Filter_Text' filter_text :: (Stream s m Char, Monad r) => ParsecT s u m (String -> r Filter_Text) filter_text = R.choice_try [ R.char '~' >> return (Regex.of_StringM >=> (return . Filter_Text_Regex)) , R.char '=' >> return (\s -> return (Filter_Text_Exact $ Text.pack s)) , return (\s -> return (Filter_Text_Exact $ Text.pack s)) ] filter_text_operator :: Stream s m Char => ParsecT s u m String filter_text_operator = R.choice_try [ R.string "=" , R.string "~" ] -- * Read 'Filter_Ord' filter_ord :: (Stream s m Char, Ord o) => ParsecT s u m (o -> Filter_Ord o) filter_ord = R.choice_try [ R.string "=" >> return (Filter_Ord Eq) , R.string "<=" >> return (Filter_Ord Le) -- NOTE: before "<" , R.string ">=" >> return (Filter_Ord Ge) -- NOTE: before ">" , R.string "<" >> return (Filter_Ord Lt) , R.string ">" >> return (Filter_Ord Gt) ] filter_ord_operator :: Stream s m Char => ParsecT s u m String filter_ord_operator = R.choice_try [ R.string "=" , R.string "<=" , R.string ">=" , R.string "<" , R.string ">" ] -- * Read 'Filter_Num_Abs' filter_num_abs :: (Stream s m Char, Num n) => ParsecT s u m (Filter_Ord n -> m (Either (Filter_Ord n) (Filter_Num_Abs n))) filter_num_abs = R.choice_try [ R.char '+' >> return (return . Right . Filter_Num_Abs) , return (return . Left) ] text :: Stream s m Char => String -> ParsecT s Context m Text text none_of = fromString <$> R.choice_try [ borders inside , R.many $ R.noneOf ("() " ++ none_of) ] where borders = R.between (R.char '(') (R.char ')') inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, R.many1 $ R.noneOf "()"]) preserve_inside = inside >>= (\x -> return $ '(':(x++[')'])) -- * Read 'Filter_Bool' filter_bool :: (Stream s m Char) => [ParsecT s u m (ParsecT s u m (Filter_Bool t))] -> ParsecT s u m (Filter_Bool t) filter_bool terms = R.buildExpressionParser filter_bool_operators (filter_bool_term terms) "filter_bool" filter_bool_operators :: Stream s m Char => R.OperatorTable s u m (Filter.Filter_Bool t) filter_bool_operators = [ [ prefix "- " Filter.Not ] , [ binary " & " Filter.And R.AssocLeft ] , [ binary " + " Filter.Or R.AssocLeft , binary " - " (\x -> Filter.And x . Filter.Not) R.AssocLeft ] ] where binary name fun = R.Infix (filter_bool_operator name >> return fun) prefix name fun = R.Prefix (filter_bool_operator name >> return fun) -- postfix name fun = Text.Parsec.Expr.Postfix (filter_bool_operator name >> return fun) filter_bool_operator :: Stream s m Char => String -> ParsecT s u m () filter_bool_operator name = R.try $ (R.string name >> R.notFollowedBy filter_bool_operator_letter -- <* R.spaces name) filter_bool_operator_letter :: Stream s m Char => ParsecT s u m Char filter_bool_operator_letter = R.oneOf ['-', '&', '+'] filter_bool_term :: Stream s m Char => [ParsecT s u m (ParsecT s u m (Filter_Bool t))] -> ParsecT s u m (Filter_Bool t) filter_bool_term terms = (do join $ R.choice_try ( (R.lookAhead (R.try (R.spaces >> R.char '(')) >> (return $ parens $ Data.Foldable.foldr Filter.And Filter.Any <$> R.many (R.try (R.spaces >> expr)) )) : terms ) <* R.spaces) "boolean-term" where expr = R.lookAhead (R.try R.anyToken) >> R.notFollowedBy (R.char ')') >> filter_bool terms parens :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a parens = R.between (R.spaces >> R.char '(') (R.spaces >> R.char ')') bool :: Stream s m Char => ParsecT s u m Bool bool = do R.choice_try [ R.choice_try [ R.string "1" , R.string "true" , R.string "t" ] >> return True , R.choice_try [ R.string "0" , R.string "false" , R.string "f" ] >> return False ] jump :: Stream s m Char => [String] -> ParsecT s u m b -> a -> ParsecT s u m a jump prefixes next r = R.choice_try (map (\s -> R.string s >> return r) prefixes) <* R.lookAhead (R.try next) -- * Read 'Filter_Account' account_section_sep :: Char account_section_sep = ':' filter_account_path :: Stream s m Char => ParsecT s u m (Filter_Path Account_Section) filter_account_path = do R.notFollowedBy $ R.space_horizontal Filter_Ord o () <- R.option (Filter_Ord Eq ()) $ R.try $ (\f -> f ()) <$> filter_ord strings <- R.many1_separated (R.many (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c)))) (R.char account_section_sep) sections <- forM strings $ \s -> case s of "" -> return Filter_Path_Section_Many "*" -> return Filter_Path_Section_Any '~':t -> Filter_Path_Section_Text . Filter_Text_Regex <$> Regex.of_StringM t t -> return $ Filter_Path_Section_Text $ Filter_Text_Exact $ Text.pack t return $ Filter_Path o $ (if sections == [] then [Filter_Path_Section_Many] else sections) filter_account :: ( Stream s m Char , Filter.Account a ) => ParsecT s Context m (Filter_Account a) filter_account = Data.Foldable.foldr Filter.And Filter.Any <$> do R.many $ R.spaces >> R.lookAhead R.anyToken >> filter_bool filter_account_terms filter_account_terms :: ( Stream s m Char , Filter.Account a ) => [ParsecT s Context m (ParsecT s Context m (Filter_Account a))] filter_account_terms = [ jump [ "AT" ] filter_account_operator $ Bool . Filter.Filter_Account_Tag <$> filter_tag , return $ Bool . Filter.Filter_Account_Path <$> filter_account_path ] filter_account_operator :: Stream s m Char => ParsecT s u m String filter_account_operator = R.choice_try [ filter_ord_operator ] -- * Read 'Filter_Amount' filter_amount :: (Stream s m Char, Amount a, Amount_Quantity a ~ Filter.Amount.Quantity) => (Filter_Ord (Amount_Quantity a) -> Filter_Polarized (Amount_Quantity a)) -> ParsecT s u m (Filter_Amount a) filter_amount flt_polarized = do R.notFollowedBy $ R.space_horizontal R.choice_try [ filter_ord >>= \flt_ord -> do amt <- Amount.Read.amount return $ And (Bool $ Filter_Amount_Section_Quantity (flt_polarized $ flt_ord $ Filter.Amount.amount_quantity amt)) (case Unit.unit_text $ Filter.amount_unit amt of u | Text.null u -> Any u -> Bool $ Filter_Amount_Section_Unit (Filter_Unit (Filter_Text_Exact u))) , filter_text >>= \flt_ord -> do unit_ <- Amount.Read.unit >>= flt_ord . Text.unpack . Unit.unit_text return $ Bool $ Filter_Amount_Section_Unit (Filter_Unit unit_) ] filter_amount_operator :: Stream s m Char => ParsecT s u m String filter_amount_operator = R.choice_try [ filter_ord_operator , filter_text_operator ] -- * Read 'Filter_Date' filter_date :: (Stream s (R.Error_State Error m) Char, Monad m) => ParsecT s Context (R.Error_State Error m) (Filter_Bool Filter_Date) filter_date = do join $ R.choice_try [ R.char '=' >> (return $ read_date_pattern) , filter_ord >>= \tst -> return $ do ctx <- R.getState let (year, _, _) = Date.gregorian $ context_date ctx liftM (Bool . Filter_Date_UTC . tst) $ Date.Read.date Error_Filter_Date (Just year) ] where read_date_pattern :: (Stream s (R.Error_State Error m) Char, Monad m) => ParsecT s u (R.Error_State Error m) (Filter_Bool Filter_Date) read_date_pattern = (do let read2 = of_digits <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit) n0 <- read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit n1 <- R.option Nothing $ R.try $ do _ <- R.char '/' Just <$> read_interval Error_Filter_Date_Interval read2 n2 <- R.option Nothing $ R.try $ do _ <- R.char '/' Just <$> read_interval Error_Filter_Date_Interval read2 let (year, month, dom) = case (n1, n2) of (Nothing, Nothing) -> ( Interval.unlimited , n0 , Interval.unlimited ) (Just d1, Nothing) -> ( Interval.unlimited , n0 , d1 ) (Nothing, Just _d2) -> assert False undefined (Just d1, Just d2) -> ( n0 , d1 , d2 ) (hour, minute, second) <- R.option (Interval.unlimited, Interval.unlimited, Interval.unlimited) $ R.try $ do _ <- R.char '_' hour <- read_interval Error_Filter_Date_Interval read2 sep <- Date.Read.hour_separator minute <- read_interval Error_Filter_Date_Interval read2 second <- R.option Interval.unlimited $ R.try $ do _ <- R.char sep read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit -- tz <- R.option Time.utc $ R.try $ do -- -- R.skipMany $ R.space_horizontal -- Date.Read.time_zone return ( hour , minute , second ) return $ foldr And Any $ catMaybes $ [ just_when_limited (Filter_Date_Year . Filter_Interval_In) year , just_when_limited (Filter_Date_Month . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) month) , just_when_limited (Filter_Date_DoM . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) dom) , just_when_limited (Filter_Date_Hour . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) hour) , just_when_limited (Filter_Date_Minute . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) minute) , just_when_limited (Filter_Date_Second . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) second) ] ) "date-filter" where of_digits :: Num n => [Char] -> n of_digits = fromInteger . R.integer_of_digits 10 just_when_limited f x = if x == Interval.unlimited then Nothing else Just $ Bool $ f x read_interval :: (Stream s (R.Error_State e m) Char, Monad m, Ord x) => ((x, x) -> e) -> ParsecT s u (R.Error_State e m) x -> ParsecT s u (R.Error_State e m) (Interval (Interval.Unlimitable x)) read_interval err read_digits = do l <- R.choice_try [ R.string ".." >> return Interval.Unlimited_low , Interval.Limited <$> read_digits ] R.choice_try [ when (l /= Interval.Unlimited_low) (void $ R.string "..") >> do h <- R.choice_try [ Interval.Limited <$> read_digits , return Interval.Unlimited_high ] case (Interval.<=..<=) l h of Nothing -> R.fail_with "interval" (err $ (Interval.limited l, Interval.limited h)) Just i -> return i , return $ case l of Interval.Limited _ -> Interval.point l _ -> Interval.unlimited ] filter_date_operator :: Stream s m Char => ParsecT s u m String filter_date_operator = filter_ord_operator -- * Read 'Filter_Description' filter_description :: Stream s m Char => ParsecT s u m Filter_Text filter_description = (do make_filter_text <- filter_text R.between (R.char '"') (R.char '"') $ make_filter_text =<< (R.many $ R.try $ R.satisfy (/= '"')) ) "description" filter_description_operator :: Stream s m Char => ParsecT s u m String filter_description_operator = filter_text_operator -- * Read 'Filter_Tag' filter_tag :: Stream s m Char => ParsecT s u m Filter_Tags filter_tag = do R.notFollowedBy $ R.space_horizontal Filter_Ord o () <- (\f -> f ()) <$> filter_ord filter_tag_value <- R.choice_try [ R.char '<' >> return Filter_Tag_Value_First , R.char '>' >> return Filter_Tag_Value_Last , return Filter_Tag_Value_Any ] strings <- R.many1_separated (R.many (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c)))) (R.char account_section_sep) sections <- forM strings $ \s -> case s of "" -> return Filter_Path_Section_Many "*" -> return Filter_Path_Section_Any '~':t -> Filter_Path_Section_Text . Filter_Text_Regex <$> Regex.of_StringM t t -> return $ Filter_Path_Section_Text $ Filter_Text_Exact $ Text.pack t case reverse sections of [] -> R.parserZero [p] -> return $ Bool $ Filter_Tag_Path $ Filter_Path o [p] value:rev_path -> return $ And (Bool $ Filter_Tag_Path $ Filter_Path o $ reverse rev_path) (Bool $ Filter_Tag_Value $ filter_tag_value $ case value of Filter_Path_Section_Any -> Filter_Text_Any Filter_Path_Section_Many -> Filter_Text_Any Filter_Path_Section_Text ft -> ft ) filter_tag_operator :: Stream s m Char => ParsecT s u m String filter_tag_operator = do void filter_ord_operator R.choice_try [ R.string "<" , R.string ">" , R.string "" ] -- * Read 'Filter_Posting' filter_posting :: ( Stream s m Char , Filter.Posting p , Amount_Quantity (Posting_Amount p) ~ Filter.Amount.Quantity ) => ParsecT s Context m (Filter_Bool (Filter_Posting p)) filter_posting = Data.Foldable.foldr Filter.And Filter.Any <$> do R.many $ R.spaces >> R.lookAhead R.anyToken >> filter_bool filter_posting_terms filter_posting_terms :: ( Stream s m Char , Filter.Posting p , Amount_Quantity (Posting_Amount p) ~ Filter.Amount.Quantity ) => [ParsecT s Context m (ParsecT s Context m (Filter_Bool (Filter_Posting p)))] filter_posting_terms = [ jump [ "a", "amount" ] filter_amount_operator $ Bool . Filter.Filter_Posting_Amount <$> filter_amount Filter_Polarized_Sum , jump [ "[]" ] (return ()) $ return $ Bool $ Filter_Posting_Type $ Filter_Posting_Type_Exact Posting_Type_Virtual , return $ Bool . Filter_Posting_Account <$> filter_account ] -- * Read 'Filter_Transaction' filter_transaction :: ( Stream s (R.Error_State Error m) Char , Monad m , Filter.Transaction t , Amount_Quantity (Posting_Amount (Transaction_Posting t)) ~ Filter.Amount.Quantity ) => ParsecT s Context (R.Error_State Error m) (Filter_Bool (Filter_Transaction t)) filter_transaction = glue_posting . Data.Foldable.foldr Filter.And Filter.Any <$> do R.many $ R.spaces >> R.lookAhead R.anyToken >> filter_bool filter_transaction_terms where glue_posting :: Transaction t => Filter_Bool (Filter_Transaction t) -> Filter_Bool (Filter_Transaction t) glue_posting fb = case fb of Any -> Any Bool p -> Bool p (Or b0 b1) -> Or (glue_posting b0) (glue_posting b1) (Not b) -> case glue_posting b of Bool (Filter_Transaction_Posting p) -> Bool $ Filter_Transaction_Posting $ Not p bb -> Not bb (And b0 b1) -> case (glue_posting b0, glue_posting b1) of ( Bool (Filter_Transaction_Posting p0), Bool (Filter_Transaction_Posting p1) ) -> Bool $ Filter_Transaction_Posting $ And p0 p1 (Bool (Filter_Transaction_Posting p0), Any) -> Bool $ Filter_Transaction_Posting $ p0 (Any, Bool (Filter_Transaction_Posting p1)) -> Bool $ Filter_Transaction_Posting $ p1 (b0', b1') -> And b0' b1' filter_transaction_terms :: ( Stream s (R.Error_State Error m) Char , Filter.Transaction t , Monad m , Amount_Quantity (Posting_Amount (Transaction_Posting t)) ~ Filter.Amount.Quantity ) => [ParsecT s Context (R.Error_State Error m) (ParsecT s Context (R.Error_State Error m) (Filter_Bool (Filter_Transaction t)))] filter_transaction_terms = -- , jump [ "atag" ] comp_text parseFilterATag -- , jump [ "code" ] comp_text parseFilterCode [ jump [ "AT" ] filter_account_operator $ Bool . Filter_Transaction_Posting . Bool . Filter_Posting_Account . Bool . Filter_Account_Tag <$> filter_tag , jump [ "date", "d" ] filter_date_operator (Bool . Filter.Filter_Transaction_Date <$> filter_date) , jump [ "tag", "T" ] filter_tag_operator (Bool . Filter.Filter_Transaction_Tag <$> filter_tag) , jump [ "debit", "D" ] filter_amount_operator (( Bool . Filter_Transaction_Posting . Bool . Filter_Posting_Amount ) <$> filter_amount Filter_Polarized_Positive) , jump [ "credit", "C" ] filter_amount_operator (( Bool . Filter_Transaction_Posting . Bool . Filter_Posting_Amount ) <$> filter_amount Filter_Polarized_Negative) , jump [ "wording", "W" ] filter_description_operator (Bool . Filter.Filter_Transaction_Description <$> filter_description) -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2 -- , jump [ "real" ] (R.char '=') parseFilterReal -- , jump [ "status" ] (R.char '=') parseFilterStatus -- , jump [ "sym" ] comp_text parseFilterSym -- , R.lookAhead comp_num >> return parseFilterAmount , return $ Bool . Filter_Transaction_Posting . Bool . Filter_Posting_Account <$> filter_account ] -- * Read 'Filter_Balance' filter_balance :: ( Stream s m Char , Filter.Balance t , Amount_Quantity (Filter.Balance_Amount t) ~ Filter.Amount.Quantity ) => ParsecT s Context m (Filter_Bool (Filter_Balance t)) filter_balance = Data.Foldable.foldr Filter.And Filter.Any <$> do R.many $ R.spaces >> R.lookAhead R.anyToken >> filter_bool filter_balance_terms filter_balance_terms :: ( Stream s m Char , Filter.Balance t , Amount_Quantity (Filter.Balance_Amount t) ~ Filter.Amount.Quantity ) => [ParsecT s Context m (ParsecT s Context m (Filter_Bool (Filter_Balance t)))] filter_balance_terms = [ jump [ "AT" ] filter_account_operator $ Bool . Filter_Balance_Account . Bool . Filter_Account_Tag <$> filter_tag , jump [ "RD", "debit" ] filter_amount_operator ( Bool . Filter_Balance_Amount <$> filter_amount Filter_Polarized_Positive) , jump [ "RC", "credit" ] filter_amount_operator ( Bool . Filter_Balance_Amount <$> filter_amount Filter_Polarized_Negative) , jump [ "RB", "balance" ] filter_amount_operator ( Bool . Filter_Balance_Amount <$> filter_amount Filter_Polarized_Sum) , return $ Bool . Filter_Balance_Account <$> filter_account ] -- * Read 'Filter_GL' filter_gl :: ( Stream s m Char , Filter.GL t , Amount_Quantity (Filter.GL_Amount t) ~ Filter.Amount.Quantity ) => ParsecT s Context m (Filter_Bool (Filter_GL t)) filter_gl = Data.Foldable.foldr Filter.And Filter.Any <$> do R.many $ R.spaces >> R.lookAhead R.anyToken >> filter_bool filter_gl_terms filter_gl_terms :: ( Stream s m Char , Filter.GL t , Amount_Quantity (Filter.GL_Amount t) ~ Filter.Amount.Quantity ) => [ParsecT s Context m (ParsecT s Context m (Filter_Bool (Filter_GL t)))] filter_gl_terms = [ jump [ "AT" ] filter_account_operator $ Bool . Filter_GL_Account . Bool . Filter_Account_Tag <$> filter_tag , jump [ "D", "debit" ] filter_amount_operator ( Bool . Filter_GL_Amount <$> filter_amount Filter_Polarized_Positive) , jump [ "C", "credit" ] filter_amount_operator ( Bool . Filter_GL_Amount <$> filter_amount Filter_Polarized_Negative) , jump [ "B", "balance" ] filter_amount_operator ( Bool . Filter_GL_Amount <$> filter_amount Filter_Polarized_Sum) , jump [ "RD", "running-debit" ] filter_amount_operator ( Bool . Filter_GL_Sum <$> filter_amount Filter_Polarized_Positive) , jump [ "RC", "running-credit" ] filter_amount_operator ( Bool . Filter_GL_Sum <$> filter_amount Filter_Polarized_Negative) , jump [ "RB", "running-balance" ] filter_amount_operator ( Bool . Filter_GL_Sum <$> filter_amount Filter_Polarized_Sum) , return $ Bool . Filter_GL_Account <$> filter_account ]