lib/Hcompta/Filter/Read.hs

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