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 -- ** Read 'Test_Amount'
 310 test_amount
 311  :: Stream s m Char
 312  => ParsecT s u m (Test_Amount Amount)
 313 test_amount = do
 314         R.notFollowedBy $ R.space_horizontal
 315         tst <- test_ord
 316         amt <- Amount.Read.amount
 317         return $ Test_Amount
 318          (tst $ Amount.quantity amt) $
 319          (Test_Unit $
 320                 case Unit.text $ Amount.unit amt of
 321                  unit | Text.null unit -> Test_Text_Any
 322                  unit                  -> Test_Text_Exact unit)
 323
 324 test_amount_operator
 325  :: Stream s m Char
 326  => ParsecT s u m String
 327 test_amount_operator =
 328         test_ord_operator
 329
 330 -- ** Read 'Test_Date'
 331 test_date
 332  :: (Stream s (R.Error_State Error m) Char, Monad m)
 333  => ParsecT s Context (R.Error_State Error m) (Test_Bool Test_Date)
 334 test_date = do
 335         join $ R.choice_try
 336          [ R.char '=' >>
 337                 (return $ read_date_pattern)
 338          , test_ord >>= \tst ->
 339                 return $ do
 340                         ctx <- R.getState
 341                         let (year, _, _) = Date.gregorian $ context_date ctx
 342                         Date.Read.date Error_Test_Date (Just year)
 343                         >>= return . Bool . Test_Date_UTC . tst
 344          ]
 345         where
 346                 read_date_pattern
 347                  :: (Stream s (R.Error_State e m) Char, Monad m)
 348                  => ParsecT s u (R.Error_State e m) (Test_Bool Test_Date)
 349                 read_date_pattern = (do
 350                         let read2 = R.try (R.count 2 R.digit) <|> R.count 1 R.digit
 351                         n0 <- read_range $ R.many1 R.digit
 352                         n1 <- R.option Nothing $ R.try $ do
 353                                 _  <- R.char '/'
 354                                 Just <$> read_range read2
 355                         n2 <- R.option Nothing $ R.try $ do
 356                                 _ <- R.char '/'
 357                                 Just <$> read_range read2
 358                         let (year, month, dom) =
 359                                 case (n1, n2) of
 360                                  (Nothing, Nothing) ->
 361                                         ( test_range_all
 362                                         , of_digits <$> n0
 363                                         , test_range_all )
 364                                  (Just d1, Nothing) ->
 365                                         ( test_range_all
 366                                         , of_digits <$> n0
 367                                         , of_digits <$> d1 )
 368                                  (Nothing, Just _d2) -> assert False undefined
 369                                  (Just d1, Just d2) ->
 370                                         ( R.integer_of_digits 10 <$> n0
 371                                         , of_digits <$> d1
 372                                         , of_digits <$> d2 )
 373                         (hour, minute, second) <-
 374                                 R.option (test_range_all, test_range_all, test_range_all) $ R.try $ do
 375                                         R.skipMany1 $ R.space_horizontal
 376                                         hour <- read_range read2
 377                                         sep <- Date.Read.hour_separator
 378                                         minute <- read_range read2
 379                                         second <- R.option test_range_all $ R.try $ do
 380                                                 _ <- R.char sep
 381                                                 read_range $ R.many1 R.digit
 382                                         -- tz <- R.option Time.utc $ R.try $ do
 383                                         --      R.skipMany $ R.space_horizontal
 384                                         --      Date.Read.time_zone
 385                                         return
 386                                          ( of_digits <$> hour
 387                                          , of_digits <$> minute
 388                                          , of_digits <$> second
 389                                          )
 390                         return $
 391                                 foldr And Any $
 392                                 catMaybes $
 393                                  [ just_when_bounded Test_Date_Year   year
 394                                  , just_when_bounded Test_Date_Month  month
 395                                  , just_when_bounded Test_Date_DoM    dom
 396                                  , just_when_bounded Test_Date_Hour   hour
 397                                  , just_when_bounded Test_Date_Minute minute
 398                                  , just_when_bounded Test_Date_Second second
 399                                  ]
 400                         ) <?> "date-filter"
 401                         where
 402                                 of_digits :: Num n => [Char] -> n
 403                                 of_digits = fromInteger . R.integer_of_digits 10
 404                                 just_when_bounded f x =
 405                                         case x of
 406                                          Test_Range_In Nothing Nothing -> Nothing
 407                                          _ -> Just $ Bool $ f x
 408
 409 read_range :: Stream s m Char
 410  => ParsecT s u m a
 411  -> ParsecT s u m (Test_Range a)
 412 read_range read_digits = do
 413         a0 <- R.choice_try
 414                  [ R.char '*' >> return Nothing
 415                  , Just <$> read_digits
 416                  ]
 417         R.choice_try
 418          [ R.char '-' >>
 419                 (Test_Range_In a0 <$> R.choice_try
 420                  [ R.char '*' >> return Nothing
 421                  , Just <$> read_digits
 422                  ])
 423          , return $ maybe test_range_all Test_Range_Eq a0
 424          ]
 425
 426 test_date_operator
 427  :: Stream s m Char
 428  => ParsecT s u m String
 429 test_date_operator =
 430         test_ord_operator
 431
 432 -- ** Read 'Test_Tag'
 433 tag_name_sep :: Char
 434 tag_name_sep = ':'
 435
 436 test_tag_name
 437  :: Stream s m Char
 438  => ParsecT s u m Test_Tag
 439 test_tag_name = do
 440         make_test_text <- test_text
 441         R.choice_try
 442          [ R.char '*'
 443                  <* R.lookAhead test_tag_name_end
 444                  >> return (Test_Tag_Name Test_Text_Any)
 445          , R.many1 (R.notFollowedBy (R.try test_tag_name_end) >> R.anyChar)
 446                  >>= (liftM Test_Tag_Name . make_test_text)
 447          ]
 448         where
 449                 test_tag_name_end =
 450                         R.choice_try
 451                          [ test_text_operator >> return ()
 452                          , R.space_horizontal >> return ()
 453                          , R.eof
 454                          ]
 455 test_tag_value
 456  :: Stream s m Char
 457  => ParsecT s u m Test_Tag
 458 test_tag_value = do
 459         make_test_text <- test_text
 460         R.choice_try
 461          [ R.char '*'
 462                  <* R.lookAhead test_tag_value_end
 463                  >> return (Test_Tag_Value Test_Text_Any)
 464          , R.many1 (R.notFollowedBy (R.try test_tag_value_end) >> R.anyChar)
 465                  >>= (liftM Test_Tag_Value . make_test_text)
 466          ]
 467         where
 468                 test_tag_value_end =
 469                         R.choice_try
 470                          [ R.space_horizontal >> return ()
 471                          , R.eof
 472                          ]
 473
 474 test_tag
 475  :: Stream s m Char
 476  => ParsecT s u m (Test_Bool Test_Tag)
 477 test_tag = do
 478         n <- test_tag_name
 479         R.choice_try
 480          [ R.lookAhead (R.try $ test_tag_operator)
 481                  >> And (Bool n) . Bool <$> test_tag_value
 482          , return $ Bool n
 483          ]
 484
 485 test_tag_operator
 486  :: Stream s m Char
 487  => ParsecT s u m String
 488 test_tag_operator =
 489         test_text_operator
 490
 491 -- ** Read 'Test_Posting'
 492 test_posting
 493  :: (Stream s m Char, Filter.Posting t)
 494  => ParsecT s Context m (Test_Bool (Test_Posting t))
 495 test_posting =
 496         Data.Foldable.foldr Filter.And Filter.Any <$>
 497         do R.many $
 498                 R.spaces
 499                 >> R.lookAhead R.anyToken
 500                 >> test_bool test_posting_terms
 501
 502 test_posting_terms
 503  :: (Stream s m Char, Filter.Posting t)
 504  => [ParsecT s Context m (ParsecT s Context m (Test_Posting t))]
 505 test_posting_terms =
 506         [ return
 507                 ( Filter.Test_Posting_Account
 508                 <$> test_account )
 509         ]
 510
 511 -- ** Read 'Test_Transaction'
 512 test_transaction
 513  :: (Stream s (R.Error_State Error m) Char, Monad m, Filter.Transaction t
 514  , Posting_Amount (Transaction_Posting t) ~ Amount)
 515  => ParsecT s Context (R.Error_State Error m) (Test_Bool (Test_Transaction t))
 516 test_transaction =
 517         Data.Foldable.foldr Filter.And Filter.Any <$>
 518         do R.many $
 519                 R.spaces
 520                 >> R.lookAhead R.anyToken
 521                 >> test_bool test_transaction_terms
 522
 523 test_transaction_terms
 524  :: (Stream s (R.Error_State Error m) Char, Filter.Transaction t, Monad m
 525  , Posting_Amount (Transaction_Posting t) ~ Amount)
 526  => [ParsecT s Context (R.Error_State Error m)
 527     (ParsecT s Context (R.Error_State Error m) (Test_Transaction t))]
 528 test_transaction_terms =
 529         -- , jump [ "atag" ] comp_text parseFilterATag
 530         -- , jump [ "code" ] comp_text parseFilterCode
 531         [ jump [ "date" ] test_date_operator
 532                 (Filter.Test_Transaction_Date <$> test_date)
 533         , jump [ "tag" ] test_tag_operator
 534                 (Filter.Test_Transaction_Tag <$> test_tag)
 535         , jump [ "amount" ] test_amount_operator
 536                 (( Filter.Test_Transaction_Posting
 537                  . Filter.Test_Posting_Amount
 538                  ) <$> test_amount)
 539         -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
 540         -- , jump [ "description","descr","desc" ] comp_text parseFilterDesc
 541         -- , jump [ "real" ] (R.char '=') parseFilterReal
 542         -- , jump [ "status" ] (R.char '=') parseFilterStatus
 543         -- , jump [ "sym" ] comp_text parseFilterSym
 544         -- , R.lookAhead comp_num >> return parseFilterAmount
 545         , return
 546                 ( Filter.Test_Transaction_Posting
 547                 . Filter.Test_Posting_Account
 548                 <$> test_account )
 549         ]
 550
 551 -- ** Read 'Test_Balance'
 552 test_balance
 553  :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
 554  => ParsecT s Context m (Test_Bool (Test_Balance t))
 555 test_balance =
 556         Data.Foldable.foldr Filter.And Filter.Any <$>
 557         do R.many $
 558                 R.spaces
 559                 >> R.lookAhead R.anyToken
 560                 >> test_bool test_balance_terms
 561
 562 test_balance_terms
 563  :: (Stream s m Char, Filter.Balance t, Balance_Amount t ~ Amount)
 564  => [ParsecT s Context m (ParsecT s Context m (Test_Balance t))]
 565 test_balance_terms =
 566         [ jump [ "amount" ] test_amount_operator
 567                 ( Filter.Test_Balance_Amount
 568                 <$> test_amount )
 569         , jump [ "debit" ] test_amount_operator
 570                 ( Filter.Test_Balance_Positive
 571                 <$> test_amount )
 572         , jump [ "credit" ] test_amount_operator
 573                 ( Filter.Test_Balance_Negative
 574                 <$> test_amount )
 575         , return
 576                 ( Filter.Test_Balance_Account
 577                 <$> test_account )
 578         ]