lib/Hcompta/Model/Filter/Read.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 module Hcompta.Model.Filter.Read where
   6
   7 import           Prelude hiding (filter)
   8 import           Control.Applicative ((<$>), (<*))
   9 import           Control.Exception (assert)
  10 import           Control.Monad (liftM)
  11 -- import           Control.Monad.Trans.Except (ExceptT(..), throwE)
  12 import qualified Data.Char
  13 import           Data.Data
  14 import qualified Data.Foldable
  15 import           Data.Functor.Identity (Identity)
  16 import           Data.Maybe (catMaybes)
  17 import qualified Data.Time.Calendar  as Time
  18 import qualified Data.Time.Clock     as Time
  19 import qualified Text.Parsec.Expr as R
  20 import qualified Text.Parsec as R hiding
  21                   ( char
  22                   , anyChar
  23                   , crlf
  24                   , newline
  25                   , noneOf
  26                   , oneOf
  27                   , satisfy
  28                   , space
  29                   , spaces
  30                   , string
  31                   )
  32 -- import qualified Text.Parsec.Expr as R
  33 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  34 import           Data.String (fromString)
  35 import qualified Data.Text as Text
  36 import           Data.Text (Text)
  37 import           Data.Typeable ()
  38
  39 import qualified Hcompta.Lib.Regex as Regex
  40 -- import           Hcompta.Lib.Regex (Regex)
  41 import qualified Hcompta.Model.Account as Account
  42 import qualified Hcompta.Model.Date as Date
  43 import           Hcompta.Model.Date (Date)
  44 import qualified Hcompta.Model.Date.Read as Date.Read
  45 import qualified Hcompta.Model.Filter as Filter
  46 import           Hcompta.Model.Filter
  47 import qualified Hcompta.Lib.Parsec as R
  48
  49 -- * Parsers' types
  50
  51 -- ** Type 'Context'
  52
  53 data Context
  54  =   Context
  55  { context_date :: Date
  56  } deriving (Data, Eq, Show, Typeable)
  57
  58 context :: Context
  59 context =
  60         Context
  61          { context_date = Date.nil
  62          }
  63
  64 -- ** Type 'Error'
  65
  66 data Error
  67  =   Error_Unknown
  68  |   Error_Test_Date         Date.Read.Error
  69  deriving (Show)
  70
  71 -- * Read
  72
  73 read ::
  74  ( Stream s (R.Error_State Error Identity) Char
  75  , Show t
  76  )
  77  => ParsecT s Context (R.Error_State Error Identity) (Test_Bool t)
  78  -> s -> IO (Either [R.Error Error] (Test_Bool t))
  79 read t s = do
  80         context_date <- Time.getCurrentTime
  81         return $
  82                 R.runParser_with_Error t context{context_date} "" s
  83
  84 -- ** Read 'Test_Text'
  85 test_text
  86  :: (Stream s m Char, Monad r)
  87  => ParsecT s u m (String -> r Test_Text)
  88 test_text =
  89         R.choice_try
  90          [ R.char '~' >> return (\s -> Regex.of_StringM s >>= (return . Test_Text_Regex))
  91          , R.char '=' >> return (\s -> return (Test_Text_Exact $ Text.pack s))
  92          ,               return (\s -> return (Test_Text_Exact $ Text.pack s))
  93          ]
  94
  95 -- ** Read 'Test_Ord'
  96 test_ord
  97  :: (Stream s m Char, Ord o)
  98  => ParsecT s u m (o -> Test_Ord o)
  99 test_ord =
 100         R.choice_try
 101          [ R.string "="  >> return Test_Ord_Eq
 102          , R.string "<=" >> return Test_Ord_Le
 103          , R.string ">=" >> return Test_Ord_Ge
 104          , R.string "<"  >> return Test_Ord_Lt
 105          , R.string ">"  >> return Test_Ord_Gt
 106          ]
 107
 108 test_ord_operator
 109  :: Stream s m Char
 110  => ParsecT s u m String
 111 test_ord_operator =
 112         R.choice_try
 113          [ R.string "="
 114          , R.string "<="
 115          , R.string ">="
 116          , R.string "<"
 117          , R.string ">"
 118          ]
 119
 120 -- ** Read 'Test_Num_Abs'
 121 test_num_abs
 122  :: (Stream s m Char, Num n)
 123  => ParsecT s u m (Test_Ord n -> m (Either (Test_Ord n) (Test_Num_Abs n)))
 124 test_num_abs =
 125         R.choice_try
 126          [ R.char '+' >> return (return . Right . Test_Num_Abs)
 127          , return (return . Left)
 128          ]
 129
 130 text :: Stream s m Char => String -> ParsecT s Context m Text
 131 text none_of =
 132         fromString <$>
 133         R.choice_try
 134          [ borders inside
 135          , R.many $ R.noneOf ("() " ++ none_of)
 136          ]
 137         where
 138                 borders = R.between (R.char '(') (R.char ')')
 139                 inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, R.many1 $ R.noneOf "()"])
 140                 preserve_inside = inside >>= (\x -> return $ '(':(x++')':[]))
 141
 142 -- ** Read 'Test_Bool'
 143
 144 test_bool
 145  :: (Stream s m Char)
 146  => [ParsecT s Context m (ParsecT s Context m t)]
 147  -> ParsecT s Context m (Test_Bool t)
 148 test_bool terms =
 149         R.buildExpressionParser
 150          test_bool_operators
 151          (test_bool_term terms)
 152         <?> "test_bool"
 153
 154 test_bool_operators
 155  :: Stream s m Char
 156  => R.OperatorTable s u m (Filter.Test_Bool t)
 157 test_bool_operators =
 158         [ [ prefix "- "   Filter.Not
 159           , prefix "not " Filter.Not
 160           ]
 161         , [ binary " & "   Filter.And                     R.AssocLeft
 162           , binary " and " Filter.And                     R.AssocLeft
 163           , binary " - "   (flip Filter.And . Filter.Not) R.AssocLeft
 164           , binary " but " (flip Filter.And . Filter.Not) R.AssocLeft
 165           ]
 166         , [ binary " + "  Filter.Or R.AssocLeft
 167           , binary " or " Filter.Or R.AssocLeft
 168           ]
 169         ]
 170         where
 171                 binary  name fun assoc = R.Infix  (test_bool_operator name >> return fun) assoc
 172                 prefix  name fun       = R.Prefix (test_bool_operator name >> return fun)
 173                 -- postfix name fun       = Text.Parsec.Expr.Postfix (test_bool_operator name >> return fun)
 174
 175 test_bool_operator
 176  :: Stream s m Char
 177  => String -> ParsecT s u m ()
 178 test_bool_operator name =
 179         lexeme $ R.try $
 180                 (R.string name
 181                 >> R.notFollowedBy test_bool_operator_letter
 182                 <?> ("end of " ++ show name))
 183
 184 test_bool_operator_letter
 185  :: Stream s m Char => ParsecT s u m Char
 186 test_bool_operator_letter =
 187         R.oneOf ['+', '-', '&']
 188
 189 test_bool_term
 190  :: Stream s m Char
 191  => [ParsecT s Context m (ParsecT s Context m t)]
 192  ->  ParsecT s Context m (Test_Bool t)
 193 test_bool_term terms = do
 194         r <- R.choice_try
 195          ( (R.lookAhead (R.try $ R.char '(')
 196                 >> (return $ parens $
 197                         Data.Foldable.foldr Filter.And Filter.Any <$>
 198                         R.many (R.spaces >> expr) ))
 199          : map ((Filter.Bool <$>) <$>) terms
 200          ) <* R.spaces <?> "filter expression"
 201         r
 202         where
 203                 expr =
 204                         R.lookAhead (R.try R.anyToken)
 205                         >> R.notFollowedBy (R.char ')')
 206                         >> test_bool terms
 207
 208 lexeme
 209  :: Stream s m Char
 210  => ParsecT s u m a -> ParsecT s u m a
 211 lexeme p = p <* R.spaces
 212
 213 parens
 214  :: Stream s m Char
 215  => ParsecT s u m a -> ParsecT s u m a
 216 parens = R.between (lexeme $ R.char '(') (lexeme $ R.char ')')
 217
 218 bool :: Stream s m Char => ParsecT s u m Bool
 219 bool = do
 220         R.choice_try
 221          [ R.choice_try
 222                  [ R.string "1"
 223                  , R.string "true"
 224                  , R.string "t"
 225                  ] >> return True
 226          , R.choice_try
 227                  [ R.string "0"
 228                  , R.string "false"
 229                  , R.string "f"
 230                  ] >> return False
 231          ]
 232
 233 -- ** Read Account.'Account.Name'
 234 account_name :: Stream s m Char => ParsecT s u m Account.Name
 235 account_name = do
 236         fromString <$> do
 237         R.many1 $ R.try account_name_char
 238         where
 239                 account_name_char :: Stream s m Char => ParsecT s u m Char
 240                 account_name_char = do
 241                         c <- R.anyChar
 242                         case c of
 243                          -- _ | c == comment_begin -> R.parserZero
 244                          -- _ | c == account_name_sep -> R.parserZero
 245                          _ | R.is_space_horizontal c -> do
 246                                 _ <- R.notFollowedBy $ R.space_horizontal
 247                                 return c <* (R.lookAhead $ R.try $
 248                                  ( R.try (R.char account_name_sep)
 249                                  <|> account_name_char
 250                                  ))
 251                          _ | not (Data.Char.isSpace c) -> return c
 252                          _ -> R.parserZero
 253
 254 -- ** Read 'Test_Account_Section'
 255 test_account_section
 256  :: (Stream s m Char)
 257  => (String -> ParsecT s u m Test_Text)
 258  -> ParsecT s u m Test_Account_Section
 259 test_account_section make_test_text = do
 260         R.choice_try
 261          [ R.char '*'
 262                  <* R.lookAhead account_section_end
 263                  >> return Test_Account_Section_Any
 264          , R.many1 (R.satisfy (\c -> c /= account_name_sep && not (Data.Char.isSpace c)))
 265                  >>= (liftM Test_Account_Section_Text . make_test_text)
 266          , R.lookAhead account_section_end
 267                  >> R.many (R.try (R.char account_name_sep >> R.lookAhead (R.try account_section_end)))
 268                  >> return Test_Account_Section_Many
 269          ]
 270         where
 271                 account_section_end =
 272                         R.choice_try
 273                          [ R.char account_name_sep >> return ()
 274                          , R.space_horizontal >> return ()
 275                          , R.eof
 276                          ]
 277
 278 -- ** Read 'Test_Account'
 279 account_name_sep :: Char
 280 account_name_sep = ':'
 281
 282 test_account
 283  :: Stream s m Char
 284  => ParsecT s u m Test_Account
 285 test_account = do
 286         R.notFollowedBy $ R.space_horizontal
 287         make_test_text <- test_text
 288         R.many1_separated (test_account_section make_test_text) $
 289                 R.char account_name_sep
 290
 291 -- ** Read 'Test_Date'
 292 test_date
 293  :: (Stream s (R.Error_State Error m) Char, Monad m)
 294  => ParsecT s Context (R.Error_State Error m) (Test_Bool Test_Date)
 295 test_date = do
 296         R.choice_try
 297          [ R.char '=' >>
 298                 (return $ read_date_pattern)
 299          , test_ord >>= \tst ->
 300                 return $ do
 301                         ctx <- R.getState
 302                         let (year, _, _) = Date.gregorian $ context_date ctx
 303                         Date.Read.date Error_Test_Date (Just year)
 304                         >>= return . Bool . Test_Date_UTC . tst
 305          ] >>= id
 306         where
 307                 read_date_pattern
 308                  :: (Stream s (R.Error_State e m) Char, Monad m)
 309                  => ParsecT s u (R.Error_State e m) (Test_Bool Test_Date)
 310                 read_date_pattern = (do
 311                         let read2 = R.try (R.count 2 R.digit) <|> R.count 1 R.digit
 312                         n0 <- read_range $ R.many1 R.digit
 313                         n1 <- R.option Nothing $ R.try $ do
 314                                 _  <- R.char '/'
 315                                 Just <$> read_range read2
 316                         n2 <- R.option Nothing $ R.try $ do
 317                                 _ <- R.char '/'
 318                                 Just <$> read_range read2
 319                         let (year, month, dom) =
 320                                 case (n1, n2) of
 321                                  (Nothing, Nothing) ->
 322                                         ( test_range_all
 323                                         , of_digits <$> n0
 324                                         , test_range_all )
 325                                  (Just d1, Nothing) ->
 326                                         ( test_range_all
 327                                         , of_digits <$> n0
 328                                         , of_digits <$> d1 )
 329                                  (Nothing, Just _d2) -> assert False undefined
 330                                  (Just d1, Just d2) ->
 331                                         ( R.integer_of_digits 10 <$> n0
 332                                         , of_digits <$> d1
 333                                         , of_digits <$> d2 )
 334                         (hour, minute, second) <-
 335                                 R.option (test_range_all, test_range_all, test_range_all) $ R.try $ do
 336                                         R.skipMany1 $ R.space_horizontal
 337                                         hour <- read_range read2
 338                                         sep <- Date.Read.hour_separator
 339                                         minute <- read_range read2
 340                                         second <- R.option test_range_all $ R.try $ do
 341                                                 _ <- R.char sep
 342                                                 read_range $ R.many1 R.digit
 343                                         -- tz <- R.option Time.utc $ R.try $ do
 344                                         --      R.skipMany $ R.space_horizontal
 345                                         --      Date.Read.time_zone
 346                                         return
 347                                          ( of_digits <$> hour
 348                                          , of_digits <$> minute
 349                                          , of_digits <$> second
 350                                          )
 351                         return $
 352                                 foldr And Any $
 353                                 catMaybes $
 354                                  [ just_when_bounded Test_Date_Year   year
 355                                  , just_when_bounded Test_Date_Month  month
 356                                  , just_when_bounded Test_Date_DoM    dom
 357                                  , just_when_bounded Test_Date_Hour   hour
 358                                  , just_when_bounded Test_Date_Minute minute
 359                                  , just_when_bounded Test_Date_Second second
 360                                  ]
 361                         ) <?> "date-filter"
 362                         where
 363                                 of_digits :: Num n => [Char] -> n
 364                                 of_digits = fromInteger . R.integer_of_digits 10
 365                                 just_when_bounded f x =
 366                                         case x of
 367                                          Test_Range_In Nothing Nothing -> Nothing
 368                                          _ -> Just $ Bool $ f x
 369
 370 read_range :: Stream s m Char
 371  => ParsecT s u m a
 372  -> ParsecT s u m (Test_Range a)
 373 read_range read_digits = do
 374         a0 <- R.choice_try
 375                  [ R.char '*' >> return Nothing
 376                  , Just <$> read_digits
 377                  ]
 378         R.choice_try
 379          [ R.char '-' >>
 380                 (Test_Range_In a0 <$> R.choice_try
 381                  [ R.char '*' >> return Nothing
 382                  , Just <$> read_digits
 383                  ])
 384          , return $ maybe test_range_all Test_Range_Eq a0
 385          ]
 386
 387 test_date_operator
 388  :: Stream s m Char
 389  => ParsecT s u m String
 390 test_date_operator =
 391         test_ord_operator
 392
 393 -- ** Read 'Test_Posting'
 394 test_posting
 395  :: (Stream s m Char, Filter.Posting t)
 396  => ParsecT s Context m (Test_Bool (Test_Posting t))
 397 test_posting =
 398         Data.Foldable.foldr Filter.And Filter.Any <$>
 399         do R.many $
 400                 R.spaces
 401                 >> R.lookAhead R.anyToken
 402                 >> test_bool test_posting_terms
 403
 404 test_posting_terms
 405  :: (Stream s m Char, Filter.Posting t)
 406  => [ParsecT s Context m (ParsecT s Context m (Test_Posting t))]
 407 test_posting_terms =
 408         [ return
 409                 ( Filter.Test_Posting_Account
 410                 <$> test_account )
 411         ]
 412
 413 -- ** Read 'Test_Transaction'
 414 test_transaction
 415  :: (Stream s (R.Error_State Error m) Char, Monad m, Filter.Transaction t)
 416  => ParsecT s Context (R.Error_State Error m) (Test_Bool (Test_Transaction t))
 417 test_transaction =
 418         Data.Foldable.foldr Filter.And Filter.Any <$>
 419         do R.many $
 420                 R.spaces
 421                 >> R.lookAhead R.anyToken
 422                 >> test_bool test_transaction_terms
 423
 424 test_transaction_terms
 425  :: (Stream s (R.Error_State Error m) Char, Filter.Transaction t, Monad m)
 426  => [ParsecT s Context (R.Error_State Error m)
 427     (ParsecT s Context (R.Error_State Error m) (Test_Transaction t))]
 428 test_transaction_terms =
 429         -- , jump [ "account","acct" ] comp_text test_account
 430         -- , jump [ "amount", "amt" ] comp_num parseFilterAmount
 431         -- , jump [ "atag" ] comp_text parseFilterATag
 432         -- , jump [ "balance", "bal" ] comp_num parseFilterBalance
 433         -- , jump [ "code" ] comp_text parseFilterCode
 434         [ jump [ "date" ] test_date_operator
 435                 (Filter.Test_Transaction_Date <$> test_date)
 436         -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
 437         -- , jump [ "depth" ] comp_num parseFilterDepth
 438         -- , jump [ "description","descr","desc" ] comp_text parseFilterDesc
 439         -- , jump [ "real" ] (R.char '=') parseFilterReal
 440         -- , jump [ "status" ] (R.char '=') parseFilterStatus
 441         -- , jump [ "sym" ] comp_text parseFilterSym
 442         -- , jump [ "tag" ] comp_text parseFilterTag
 443         -- , R.lookAhead comp_num >> return parseFilterAmount
 444         , return
 445                 ( Filter.Test_Transaction_Posting
 446                 . Filter.Test_Posting_Account
 447                 <$> test_account )
 448         ]
 449         where
 450                 jump :: Stream s m Char
 451                  => [String]
 452                  -> ParsecT s u m b
 453                  -> a
 454                  -> ParsecT s u m a
 455                 jump prefixes next r =
 456                         R.choice_try
 457                          (map (\s -> R.string s >> return r) prefixes)
 458                          <* R.lookAhead (R.try next)
 459
 460 -- ** Read 'Test_Balance'
 461 test_balance
 462  :: (Stream s m Char, Filter.Balance t)
 463  => ParsecT s Context m (Test_Bool (Test_Balance t))
 464 test_balance =
 465         Data.Foldable.foldr Filter.And Filter.Any <$>
 466         do R.many $
 467                 R.spaces
 468                 >> R.lookAhead R.anyToken
 469                 >> test_bool test_balance_terms
 470
 471 test_balance_terms
 472  :: (Stream s m Char, Filter.Balance t)
 473  => [ParsecT s Context m (ParsecT s Context m (Test_Balance t))]
 474 test_balance_terms =
 475         [ return
 476                 ( Filter.Test_Balance_Account
 477                 <$> test_account )
 478         ]
 479
 480 {-
 481
 482 account :: Stream s m Char => ParsecT s Context m Filter
 483 account = do
 484         o <- R.optionMaybe comp_text
 485         liftM (Filter.Account $ fromMaybe Comp_Text_Exact o)
 486          (liftM (accountNameComponents) $ string (" \t"++"+-&"))
 487
 488 parseFilterAmount :: Stream s m Char => ParsecT s Context m Filter
 489 parseFilterAmount = do
 490         Filter.Amount
 491          <$> comp_num
 492          <*> comp_num_abs
 493          <*> amount
 494
 495 parseFilterATag :: Stream s m Char => ParsecT s Context m Filter
 496 parseFilterATag = do
 497         c <- comp_text
 498         liftM (uncurry (ATag c))
 499          parseTag
 500
 501 --parseFilterCode :: Stream s m Char => ParsecT s Context m Filter
 502 --parseFilterCode = do
 503 --      string "code="
 504 --      liftM Code $
 505 --       try (do {
 506                 --              choice
 507                 --               [ inparen
 508                 --               , R.many nonspace
 509                 --               ]
 510                 --              return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
 511                 --       })
 512
 513 parseFilterBalance :: Stream s m Char => ParsecT s Context m Filter
 514 parseFilterBalance = do
 515         nc <- comp_num
 516         absc <- comp_num_abs
 517         a <- parseAmount Nothing
 518         return $ Bal (nc, absc) a
 519
 520 parseFilterDate :: Stream s m Char => ParsecT s Context m Filter
 521 parseFilterDate = do
 522         R.char '='
 523         ctx <- getState
 524         liftM Date $
 525          periodexprdatespan (qCtxDay ctx)
 526
 527 parseFilterDate2 :: Stream s m Char => ParsecT s Context m Filter
 528 parseFilterDate2 = do
 529         R.char '='
 530         ctx <- getState
 531         liftM Date2 $
 532          periodexprdatespan (qCtxDay ctx)
 533
 534 parseFilterDesc :: Stream s m Char => ParsecT s Context m Filter
 535 parseFilterDesc = do
 536         c <- comp_text
 537         liftM (Desc c)
 538          (string "")
 539
 540 parseFilterDepth :: Stream s m Char => ParsecT s Context m Filter
 541 parseFilterDepth = do
 542         c <- comp_num
 543         liftM (Depth c . fromIntegral) $
 544          parseDecimal
 545
 546 parseFilterReal :: Stream s m Char => ParsecT s Context m Filter
 547 parseFilterReal = do
 548         R.char '='
 549         liftM Real bool
 550
 551 -- | Read the boolean value part of a "status:" query, allowing "*" as
 552 -- another way to spell True, similar to the journal file format.
 553 parseFilterStatus :: Stream s m Char => ParsecT s Context m Filter
 554 parseFilterStatus = do
 555         R.char '='
 556         liftM Status $
 557          try (R.char '*' >> return True) <|> bool
 558
 559 --parseFilterSym :: Stream s m Char => ParsecT s Context m Filter
 560 --parseFilterSym = do
 561 --      string "cur="
 562 --      liftM Sym
 563 --       commoditysymbol
 564
 565 parseFilterTag :: Stream s m Char => ParsecT s Context m Filter
 566 parseFilterTag = do
 567         c <- comp_text
 568         liftM (uncurry (Tag c))
 569          parseTag
 570 -}