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