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