lib/Hcompta/Model/Filter/Read.hs

   1 module Hcompta.Model.Filter.Read where
   2
   3 import           Control.Monad (liftM)
   4 import           Control.Applicative ((<$>))
   5 import           Data.Maybe (isJust)
   6 import qualified Text.Parsec as R
   7 import qualified Text.Parsec.Expr as R
   8 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
   9
  10 import qualified Hcompta.Model.Filter as Filter
  11 import           Hcompta.Model.Filter (Comp_Number(..), Comp_String(..))
  12
  13 -- * The 'Context' type
  14
  15 data Context
  16  =   Context
  17  { context_day :: !Day
  18  } deriving (Data, Eq, Show, Typeable)
  19
  20 -- * Comparing
  21
  22 comp_string :: Stream s m Char => ParsecT s u m Comp_String
  23 comp_string =
  24         R.choice_try
  25          [ R.string "=" >> return Comp_String_Eq
  26          , R.string "~" >> return Comp_String_Regexp
  27          ]
  28
  29 comp_number :: Stream s m Char => ParsecT s u m Comp_Number
  30 comp_number =
  31         R.choice_try
  32          [ R.string "="  >> return Comp_Number_Eq
  33          , R.string "<=" >> return Comp_Number_Lt_Eq
  34          , R.string ">=" >> return Comp_Number_Gt_Eq
  35          , R.string "<"  >> return Comp_Number_Lt
  36          , R.string ">"  >> return Comp_Number_Gt
  37          ]
  38
  39 comp_number_absolute :: Stream s m Char => ParsecT s u m Comp_Num_Absolute
  40 comp_number_absolute =
  41         liftM isJust $ R.optionMaybe (char '+')
  42
  43 string :: Stream s m Char => String -> ParsecT s Context m String
  44 string none_of =
  45         R.choice_try [borders inside, R.many $ R.noneOf ("() " ++ none_of)]
  46         where
  47                 borders inside = between (char '(') (char ')') inside
  48                 inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, many1 $ R.noneOf "()"])
  49                 preserve_inside = inside >>= (\x -> return $ '(':(x++')':[]))
  50
  51 parseBool :: Stream s m Char => ParsecT s u m Bool
  52 parseBool = do
  53         R.choice_try
  54          [ R.choice_try
  55                  [ R.string "1"
  56                  , R.string "true"
  57                  , R.string "t"
  58                  ] >> return True
  59          , R.choice_try
  60                  [ R.string "0"
  61                  , R.string "false"
  62                  , R.string "f"
  63                  ] >> return False
  64          ]
  65
  66 account :: Stream s m Char => ParsecT s Context m Filter
  67 account = do
  68         o <- R.optionMaybe comp_string
  69         liftM (Filter.Account $ fromMaybe Comp_String_Eq o)
  70          (liftM (accountNameComponents) $ string (" \t"++"+-&"))
  71
  72 parseFilterAmount :: Stream s m Char => ParsecT s Context m Filter
  73 parseFilterAmount = do
  74         Filter.Amount
  75          <$> comp_number
  76          <*> comp_number_absolute
  77          <*> amount
  78
  79 parseFilterATag :: Stream s m Char => ParsecT s Context m Filter
  80 parseFilterATag = do
  81         c <- comp_string
  82         liftM (uncurry (ATag c))
  83          parseTag
  84
  85 --parseFilterCode :: Stream s m Char => ParsecT s Context m Filter
  86 --parseFilterCode = do
  87 --      string "code="
  88 --      liftM Code $
  89 --       try (do {
  90                 --              choice
  91                 --               [ inparen
  92                 --               , R.many nonspace
  93                 --               ]
  94                 --              return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
  95                 --       })
  96
  97 parseFilterBalance :: Stream s m Char => ParsecT s Context m Filter
  98 parseFilterBalance = do
  99         nc <- comp_number
 100         absc <- comp_number_absolute
 101         a <- parseAmount Nothing
 102         return $ Bal (nc, absc) a
 103
 104 parseFilterDate :: Stream s m Char => ParsecT s Context m Filter
 105 parseFilterDate = do
 106         char '='
 107         ctx <- getState
 108         liftM Date $
 109          periodexprdatespan (qCtxDay ctx)
 110
 111 parseFilterDate2 :: Stream s m Char => ParsecT s Context m Filter
 112 parseFilterDate2 = do
 113         char '='
 114         ctx <- getState
 115         liftM Date2 $
 116          periodexprdatespan (qCtxDay ctx)
 117
 118 parseFilterDesc :: Stream s m Char => ParsecT s Context m Filter
 119 parseFilterDesc = do
 120         c <- comp_string
 121         liftM (Desc c)
 122          (string "")
 123
 124 parseFilterDepth :: Stream s m Char => ParsecT s Context m Filter
 125 parseFilterDepth = do
 126         c <- comp_number
 127         liftM (Depth c . fromIntegral) $
 128          parseDecimal
 129
 130 parseFilterReal :: Stream s m Char => ParsecT s Context m Filter
 131 parseFilterReal = do
 132         char '='
 133         liftM Real
 134          parseBool
 135
 136 -- | Parse the boolean value part of a "status:" query, allowing "*" as
 137 -- another way to spell True, similar to the journal file format.
 138 parseFilterStatus :: Stream s m Char => ParsecT s Context m Filter
 139 parseFilterStatus = do
 140         char '='
 141         liftM Status $
 142          try (char '*' >> return True) <|> parseBool
 143
 144 --parseFilterSym :: Stream s m Char => ParsecT s Context m Filter
 145 --parseFilterSym = do
 146 --      string "cur="
 147 --      liftM Sym
 148 --       commoditysymbol
 149
 150 parseFilterTag :: Stream s m Char => ParsecT s Context m Filter
 151 parseFilterTag = do
 152         c <- comp_string
 153         liftM (uncurry (Tag c))
 154          parseTag
 155
 156 parens :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
 157 parens = between (parseLexeme $ char '(') (parseLexeme $ char ')')
 158
 159 operators :: Stream s m Char => R.OperatorTable s u m Filter
 160 operators =
 161         [ [ prefix "- "   Filter.Not
 162           , prefix "not " Filter.Not
 163           ]
 164         , [ binary " & "   Filter.And R.AssocLeft
 165           , binary " and " Filter.And R.AssocLeft
 166           , binary " - "   (\x y -> Filter.And x (Filter.Not y)) R.AssocLeft
 167           , binary " but " (\x y -> Filter.And x (Filter.Not y)) R.AssocLeft
 168           ]
 169         , [ binary " + "  Filter.Or R.AssocLeft
 170           , binary " or " Filter.Or R.AssocLeft
 171           ]
 172         ]
 173         where
 174                 binary  name fun assoc = R.Infix  (do{ operator name; return fun }) assoc
 175                 prefix  name fun       = R.Prefix (do{ operator name; return fun })
 176                 -- postfix name fun       = Text.Parsec.Expr.Postfix (do{ operator name; return fun })
 177
 178 operator_letter :: Stream s m Char => ParsecT s u m Char
 179 operator_letter = oneOf ['+', '-', '&']
 180
 181 operator :: Stream s m Char => String -> ParsecT s u m ()
 182 operator name =
 183         parseLexeme $ try $
 184         do{ R.string name
 185           ; R.notFollowedBy operator_letter <?> ("end of " ++ show name)
 186           }
 187
 188 parseFilterTerm :: Stream s m Char => ParsecT s Context m Filter
 189 parseFilterTerm = do
 190         r <- R.choice_try
 191          [ R.lookAhead (char '(')
 192                 >> (return $
 193                         parens (liftM (foldl (\acc x -> case acc of { Any -> x; _ -> And acc x }) Any) $
 194                         R.many $ (parseWhiteSpace >> R.lookAhead R.anyToken >> R.notFollowedBy (char ')') >> parseFilterExpr)))
 195          , jump [ "account","acct" ] comp_string parseFilterAccount
 196          , jump [ "amount", "amt" ] comp_number parseFilterAmount
 197          , jump [ "atag" ] comp_string parseFilterATag
 198          , jump [ "balance", "bal" ] comp_number parseFilterBalance
 199          -- , jump [ "code" ] comp_string parseFilterCode
 200          , jump [ "date" ] (char '=') parseFilterDate
 201          , jump [ "date2", "edate" ] (char '=') parseFilterDate2
 202          , jump [ "depth" ] comp_number parseFilterDepth
 203          , jump [ "description","descr","desc" ] comp_string parseFilterDesc
 204          , jump [ "real" ] (char '=') parseFilterReal
 205          , jump [ "status" ] (char '=') parseFilterStatus
 206          -- , jump [ "sym" ] comp_string parseFilterSym
 207          , jump [ "tag" ] comp_string parseFilterTag
 208          , R.lookAhead comp_number >> return parseFilterAmount
 209          , return parseFilterAccount
 210          ] <* parseWhiteSpace <?> "query expression"
 211         r
 212         where
 213                 jump l next r = R.choice_try (map (\s -> R.string s >> return r) l) <* R.lookAhead next
 214
 215 expr :: Stream s m Char => ParsecT s Context m Filter
 216 expr = R.buildExpressionParser operators parseFilterTerm <?> "query"
 217
 218 filter :: Stream s m Char => ParsecT s Context m Filter
 219 filter =
 220         liftM (foldl (\acc x -> case acc of { Any -> x; _ -> And acc x }) Any) $
 221                 R.many $ (parseWhiteSpace >> R.lookAhead R.anyToken >> parseFilterExpr)
 222
 223 {-
 224
 225 query :: Day -> String -> Either ParseError Filter
 226 query d s = runParser (parseFilter <* eof) QCtx{qCtxDay=d} "" s
 227
 228 simplifyFilter :: Filter -> Filter
 229 simplifyFilter q =
 230   -- let q' = simplify q
 231   -- in if q' == q then q else simplifyFilter q'
 232   simplify q -- NOTE: should be stable without recurring
 233   where
 234     simplify (And None _) = None
 235     simplify (And _ None) = None
 236     simplify (And Any Any) = Any
 237     simplify (And q q'@(Date _)) = simplify (And q' q) -- XXX: useful?
 238     simplify (And q q') | q == q' = simplify q
 239                         | otherwise = case (simplify q, simplify q') of
 240                                        (None, _) -> None
 241                                        (_, None) -> None
 242                                        (Any, q') -> q'
 243                                        (q, Any) -> q
 244                                        (q, q') -> And q q'
 245     simplify (Or None q') = simplify q'
 246     simplify (Or q None) = simplify q
 247     simplify (Or Any _) = Any
 248     simplify (Or _ Any) = Any
 249     -- simplify (Or q q'@(Date _)) = simplify (Or q' q)
 250     simplify (Or q q') | q == q' = simplify q
 251                        | otherwise = case (simplify q, simplify q') of
 252                                       (None, q') -> q'
 253                                       (q, None) -> q
 254                                       (Any, _) -> q'
 255                                       (_, Any) -> q
 256                                       (q, q') -> Or q q'
 257     simplify (Date (DateSpan Nothing Nothing)) = Any
 258     simplify (Date2 (DateSpan Nothing Nothing)) = Any
 259     simplify q = q
 260 -}