--- /dev/null
+module Hcompta.Model.Filter.Read where
+
+import Control.Monad (liftM)
+import Control.Applicative ((<$>))
+import Data.Maybe (isJust)
+import qualified Text.Parsec as R
+import qualified Text.Parsec.Expr as R
+import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
+
+import qualified Hcompta.Model.Filter as Filter
+import Hcompta.Model.Filter (Comp_Number(..), Comp_String(..))
+
+-- * The 'Context' type
+
+data Context
+ = Context
+ { context_day :: !Day
+ } deriving (Data, Eq, Show, Typeable)
+
+-- * Comparing
+
+comp_string :: Stream s m Char => ParsecT s u m Comp_String
+comp_string =
+ R.choice_try
+ [ R.string "=" >> return Comp_String_Eq
+ , R.string "~" >> return Comp_String_Regexp
+ ]
+
+comp_number :: Stream s m Char => ParsecT s u m Comp_Number
+comp_number =
+ R.choice_try
+ [ R.string "=" >> return Comp_Number_Eq
+ , R.string "<=" >> return Comp_Number_Lt_Eq
+ , R.string ">=" >> return Comp_Number_Gt_Eq
+ , R.string "<" >> return Comp_Number_Lt
+ , R.string ">" >> return Comp_Number_Gt
+ ]
+
+comp_number_absolute :: Stream s m Char => ParsecT s u m Comp_Num_Absolute
+comp_number_absolute =
+ liftM isJust $ R.optionMaybe (char '+')
+
+string :: Stream s m Char => String -> ParsecT s Context m String
+string none_of =
+ R.choice_try [borders inside, R.many $ R.noneOf ("() " ++ none_of)]
+ where
+ borders inside = between (char '(') (char ')') inside
+ inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, many1 $ R.noneOf "()"])
+ preserve_inside = inside >>= (\x -> return $ '(':(x++')':[]))
+
+parseBool :: Stream s m Char => ParsecT s u m Bool
+parseBool = 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
+ ]
+
+account :: Stream s m Char => ParsecT s Context m Filter
+account = do
+ o <- R.optionMaybe comp_string
+ liftM (Filter.Account $ fromMaybe Comp_String_Eq o)
+ (liftM (accountNameComponents) $ string (" \t"++"+-&"))
+
+parseFilterAmount :: Stream s m Char => ParsecT s Context m Filter
+parseFilterAmount = do
+ Filter.Amount
+ <$> comp_number
+ <*> comp_number_absolute
+ <*> amount
+
+parseFilterATag :: Stream s m Char => ParsecT s Context m Filter
+parseFilterATag = do
+ c <- comp_string
+ liftM (uncurry (ATag c))
+ parseTag
+
+--parseFilterCode :: Stream s m Char => ParsecT s Context m Filter
+--parseFilterCode = do
+-- string "code="
+-- liftM Code $
+-- try (do {
+ -- choice
+ -- [ inparen
+ -- , R.many nonspace
+ -- ]
+ -- return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
+ -- })
+
+parseFilterBalance :: Stream s m Char => ParsecT s Context m Filter
+parseFilterBalance = do
+ nc <- comp_number
+ absc <- comp_number_absolute
+ a <- parseAmount Nothing
+ return $ Bal (nc, absc) a
+
+parseFilterDate :: Stream s m Char => ParsecT s Context m Filter
+parseFilterDate = do
+ char '='
+ ctx <- getState
+ liftM Date $
+ periodexprdatespan (qCtxDay ctx)
+
+parseFilterDate2 :: Stream s m Char => ParsecT s Context m Filter
+parseFilterDate2 = do
+ char '='
+ ctx <- getState
+ liftM Date2 $
+ periodexprdatespan (qCtxDay ctx)
+
+parseFilterDesc :: Stream s m Char => ParsecT s Context m Filter
+parseFilterDesc = do
+ c <- comp_string
+ liftM (Desc c)
+ (string "")
+
+parseFilterDepth :: Stream s m Char => ParsecT s Context m Filter
+parseFilterDepth = do
+ c <- comp_number
+ liftM (Depth c . fromIntegral) $
+ parseDecimal
+
+parseFilterReal :: Stream s m Char => ParsecT s Context m Filter
+parseFilterReal = do
+ char '='
+ liftM Real
+ parseBool
+
+-- | Parse the boolean value part of a "status:" query, allowing "*" as
+-- another way to spell True, similar to the journal file format.
+parseFilterStatus :: Stream s m Char => ParsecT s Context m Filter
+parseFilterStatus = do
+ char '='
+ liftM Status $
+ try (char '*' >> return True) <|> parseBool
+
+--parseFilterSym :: Stream s m Char => ParsecT s Context m Filter
+--parseFilterSym = do
+-- string "cur="
+-- liftM Sym
+-- commoditysymbol
+
+parseFilterTag :: Stream s m Char => ParsecT s Context m Filter
+parseFilterTag = do
+ c <- comp_string
+ liftM (uncurry (Tag c))
+ parseTag
+
+parens :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
+parens = between (parseLexeme $ char '(') (parseLexeme $ char ')')
+
+operators :: Stream s m Char => R.OperatorTable s u m Filter
+operators =
+ [ [ prefix "- " Filter.Not
+ , prefix "not " Filter.Not
+ ]
+ , [ binary " & " Filter.And R.AssocLeft
+ , binary " and " Filter.And R.AssocLeft
+ , binary " - " (\x y -> Filter.And x (Filter.Not y)) R.AssocLeft
+ , binary " but " (\x y -> Filter.And x (Filter.Not y)) R.AssocLeft
+ ]
+ , [ binary " + " Filter.Or R.AssocLeft
+ , binary " or " Filter.Or R.AssocLeft
+ ]
+ ]
+ where
+ binary name fun assoc = R.Infix (do{ operator name; return fun }) assoc
+ prefix name fun = R.Prefix (do{ operator name; return fun })
+ -- postfix name fun = Text.Parsec.Expr.Postfix (do{ operator name; return fun })
+
+operator_letter :: Stream s m Char => ParsecT s u m Char
+operator_letter = oneOf ['+', '-', '&']
+
+operator :: Stream s m Char => String -> ParsecT s u m ()
+operator name =
+ parseLexeme $ try $
+ do{ R.string name
+ ; R.notFollowedBy operator_letter <?> ("end of " ++ show name)
+ }
+
+parseFilterTerm :: Stream s m Char => ParsecT s Context m Filter
+parseFilterTerm = do
+ r <- R.choice_try
+ [ R.lookAhead (char '(')
+ >> (return $
+ parens (liftM (foldl (\acc x -> case acc of { Any -> x; _ -> And acc x }) Any) $
+ R.many $ (parseWhiteSpace >> R.lookAhead R.anyToken >> R.notFollowedBy (char ')') >> parseFilterExpr)))
+ , jump [ "account","acct" ] comp_string parseFilterAccount
+ , jump [ "amount", "amt" ] comp_number parseFilterAmount
+ , jump [ "atag" ] comp_string parseFilterATag
+ , jump [ "balance", "bal" ] comp_number parseFilterBalance
+ -- , jump [ "code" ] comp_string parseFilterCode
+ , jump [ "date" ] (char '=') parseFilterDate
+ , jump [ "date2", "edate" ] (char '=') parseFilterDate2
+ , jump [ "depth" ] comp_number parseFilterDepth
+ , jump [ "description","descr","desc" ] comp_string parseFilterDesc
+ , jump [ "real" ] (char '=') parseFilterReal
+ , jump [ "status" ] (char '=') parseFilterStatus
+ -- , jump [ "sym" ] comp_string parseFilterSym
+ , jump [ "tag" ] comp_string parseFilterTag
+ , R.lookAhead comp_number >> return parseFilterAmount
+ , return parseFilterAccount
+ ] <* parseWhiteSpace <?> "query expression"
+ r
+ where
+ jump l next r = R.choice_try (map (\s -> R.string s >> return r) l) <* R.lookAhead next
+
+expr :: Stream s m Char => ParsecT s Context m Filter
+expr = R.buildExpressionParser operators parseFilterTerm <?> "query"
+
+filter :: Stream s m Char => ParsecT s Context m Filter
+filter =
+ liftM (foldl (\acc x -> case acc of { Any -> x; _ -> And acc x }) Any) $
+ R.many $ (parseWhiteSpace >> R.lookAhead R.anyToken >> parseFilterExpr)
+
+{-
+
+query :: Day -> String -> Either ParseError Filter
+query d s = runParser (parseFilter <* eof) QCtx{qCtxDay=d} "" s
+
+simplifyFilter :: Filter -> Filter
+simplifyFilter q =
+ -- let q' = simplify q
+ -- in if q' == q then q else simplifyFilter q'
+ simplify q -- NOTE: should be stable without recurring
+ where
+ simplify (And None _) = None
+ simplify (And _ None) = None
+ simplify (And Any Any) = Any
+ simplify (And q q'@(Date _)) = simplify (And q' q) -- XXX: useful?
+ simplify (And q q') | q == q' = simplify q
+ | otherwise = case (simplify q, simplify q') of
+ (None, _) -> None
+ (_, None) -> None
+ (Any, q') -> q'
+ (q, Any) -> q
+ (q, q') -> And q q'
+ simplify (Or None q') = simplify q'
+ simplify (Or q None) = simplify q
+ simplify (Or Any _) = Any
+ simplify (Or _ Any) = Any
+ -- simplify (Or q q'@(Date _)) = simplify (Or q' q)
+ simplify (Or q q') | q == q' = simplify q
+ | otherwise = case (simplify q, simplify q') of
+ (None, q') -> q'
+ (q, None) -> q
+ (Any, _) -> q'
+ (_, Any) -> q
+ (q, q') -> Or q q'
+ simplify (Date (DateSpan Nothing Nothing)) = Any
+ simplify (Date2 (DateSpan Nothing Nothing)) = Any
+ simplify q = q
+-}
sourcephile / git / comptalang.git / commitdiff