lib/Hcompta/Filter/Read.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE Rank2Types #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE StandaloneDeriving #-}
   8 {-# LANGUAGE TupleSections #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# OPTIONS_GHC -fno-warn-orphans #-}
  11 module Hcompta.Filter.Read where
  12
  13 import           Control.Applicative ((<$>), (<*))
  14 import           Control.Exception (assert)
  15 import           Control.Monad (Monad(..), liftM, join, when, (=<<), (>=>), void, forM)
  16 import           Data.Bool
  17 import           Data.Char
  18 import           Data.Data
  19 import           Data.Either (Either(..))
  20 import           Data.Eq (Eq(..))
  21 import qualified Data.Foldable
  22 import           Data.Foldable (Foldable(..))
  23 import           Data.Functor (Functor(..))
  24 import           Data.Functor.Identity (Identity)
  25 import           Data.List ((++), concat, map, reverse)
  26 import           Data.Maybe (Maybe(..), catMaybes)
  27 import           Data.Ord (Ord(..))
  28 import           Data.String (String, fromString)
  29 import           Data.Text (Text)
  30 import qualified Data.Text as Text
  31 import qualified Data.Time.Clock as Time
  32 import           Data.Typeable ()
  33 import           Prelude (($), (.), Integer, IO, Num(..), undefined)
  34 import qualified Text.Parsec.Expr as R
  35 import qualified Text.Parsec as R hiding
  36                   ( char
  37                   , anyChar
  38                   , crlf
  39                   , newline
  40                   , noneOf
  41                   , oneOf
  42                   , satisfy
  43                   , space
  44                   , spaces
  45                   , string
  46                   )
  47 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  48 import           Text.Show (Show(..))
  49
  50 -- import qualified Hcompta.Amount as Amount
  51 import           Hcompta.Date (Date)
  52 import qualified Hcompta.Date as Date
  53 import           Hcompta.Filter
  54 import qualified Hcompta.Filter as Filter
  55 import qualified Hcompta.Filter.Amount as Filter.Amount
  56 import qualified Hcompta.Filter.Amount.Read as Amount.Read
  57 import qualified Hcompta.Filter.Date.Read as Date.Read
  58 import           Hcompta.Lib.Interval (Interval)
  59 import qualified Hcompta.Lib.Interval as Interval
  60 import qualified Hcompta.Lib.Parsec as R
  61 import qualified Hcompta.Lib.Regex as Regex
  62 -- import           Hcompta.Polarize
  63 -- import qualified Hcompta.Quantity as Quantity
  64 import qualified Hcompta.Posting as Posting
  65 import qualified Hcompta.Unit as Unit
  66
  67 -- * Type 'Context'
  68 data Context
  69  =   Context
  70  { context_date :: Date
  71  } deriving (Data, Eq, Show, Typeable)
  72
  73 context :: Context
  74 context =
  75         Context
  76          { context_date = Date.nil
  77          }
  78
  79 -- * Type 'Error'
  80 data Error
  81  =   Error_Unknown
  82  |   Error_Filter_Date          Date.Read.Error
  83  |   Error_Filter_Date_Interval (Integer, Integer)
  84  deriving (Show)
  85
  86 -- * Read
  87 read ::
  88  ( Stream s (R.Error_State Error Identity) Char
  89  , Show t
  90  )
  91  => ParsecT s Context (R.Error_State Error Identity) (Filter_Bool t)
  92  -> s -> IO (Either [R.Error Error] (Filter_Bool t))
  93 read t s = do
  94         context_date <- Time.getCurrentTime
  95         return $
  96                 R.runParser_with_Error t context{context_date} "" s
  97
  98 -- * Read 'Filter_Text'
  99 filter_text
 100  :: (Stream s m Char, Monad r)
 101  => ParsecT s u m (String -> r Filter_Text)
 102 filter_text =
 103         R.choice_try
 104          [ R.char '~' >> return (Regex.of_StringM >=> (return . Filter_Text_Regex))
 105          , R.char '=' >> return (\s -> return (Filter_Text_Exact $ Text.pack s))
 106          ,               return (\s -> return (Filter_Text_Exact $ Text.pack s))
 107          ]
 108
 109 filter_text_operator
 110  :: Stream s m Char
 111  => ParsecT s u m String
 112 filter_text_operator =
 113         R.choice_try
 114          [ R.string "="
 115          , R.string "~"
 116          ]
 117
 118 -- * Read 'Filter_Ord'
 119 filter_ord
 120  :: (Stream s m Char, Ord o)
 121  => ParsecT s u m (o -> Filter_Ord o)
 122 filter_ord =
 123         R.choice_try
 124          [ R.string "="  >> return (Filter_Ord Eq)
 125          , R.string "<=" >> return (Filter_Ord Le) -- NOTE: before "<"
 126          , R.string ">=" >> return (Filter_Ord Ge) -- NOTE: before ">"
 127          , R.string "<"  >> return (Filter_Ord Lt)
 128          , R.string ">"  >> return (Filter_Ord Gt)
 129          ]
 130
 131 filter_ord_operator
 132  :: Stream s m Char
 133  => ParsecT s u m String
 134 filter_ord_operator =
 135         R.choice_try
 136          [ R.string "="
 137          , R.string "<="
 138          , R.string ">="
 139          , R.string "<"
 140          , R.string ">"
 141          ]
 142
 143 -- * Read 'Filter_Num_Abs'
 144 filter_num_abs
 145  :: (Stream s m Char, Num n)
 146  => ParsecT s u m (Filter_Ord n -> m (Either (Filter_Ord n) (Filter_Num_Abs n)))
 147 filter_num_abs =
 148         R.choice_try
 149          [ R.char '+' >> return (return . Right . Filter_Num_Abs)
 150          , return (return . Left)
 151          ]
 152
 153 text :: Stream s m Char => String -> ParsecT s Context m Text
 154 text none_of =
 155         fromString <$>
 156         R.choice_try
 157          [ borders inside
 158          , R.many $ R.noneOf ("() " ++ none_of)
 159          ]
 160         where
 161                 borders = R.between (R.char '(') (R.char ')')
 162                 inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, R.many1 $ R.noneOf "()"])
 163                 preserve_inside = inside >>= (\x -> return $ '(':(x++[')']))
 164
 165 -- * Read 'Filter_Bool'
 166 filter_bool
 167  :: (Stream s m Char)
 168  => [ParsecT s u m (ParsecT s u m (Filter_Bool t))]
 169  -> ParsecT s u m (Filter_Bool t)
 170 filter_bool terms =
 171         R.buildExpressionParser
 172          filter_bool_operators
 173          (filter_bool_term terms)
 174         <?> "filter_bool"
 175
 176 filter_bool_operators
 177  :: Stream s m Char
 178  => R.OperatorTable s u m (Filter.Filter_Bool t)
 179 filter_bool_operators =
 180         [ [ prefix "- "   Filter.Not
 181           ]
 182         , [ binary " & "  Filter.And R.AssocLeft
 183           ]
 184         , [ binary " + "  Filter.Or R.AssocLeft
 185           , binary " - "  (\x -> Filter.And x . Filter.Not) R.AssocLeft
 186           ]
 187         ]
 188         where
 189                 binary name fun = R.Infix  (filter_bool_operator name >> return fun)
 190                 prefix name fun = R.Prefix (filter_bool_operator name >> return fun)
 191                 -- postfix name fun       = Text.Parsec.Expr.Postfix (filter_bool_operator name >> return fun)
 192
 193 filter_bool_operator
 194  :: Stream s m Char
 195  => String -> ParsecT s u m ()
 196 filter_bool_operator name =
 197         R.try $
 198                 (R.string name
 199                 >> R.notFollowedBy filter_bool_operator_letter
 200                 -- <* R.spaces
 201                 <?> name)
 202
 203 filter_bool_operator_letter
 204  :: Stream s m Char => ParsecT s u m Char
 205 filter_bool_operator_letter =
 206         R.oneOf ['-', '&', '+']
 207
 208 filter_bool_term
 209  :: Stream s m Char
 210  => [ParsecT s u m (ParsecT s u m (Filter_Bool t))]
 211  ->  ParsecT s u m (Filter_Bool t)
 212 filter_bool_term terms = (do
 213         join $ R.choice_try
 214          ( (R.lookAhead (R.try (R.spaces >> R.char '('))
 215                 >> (return $ parens $
 216                         Data.Foldable.foldr Filter.And Filter.Any <$>
 217                         R.many (R.try (R.spaces >> expr)) ))
 218          : terms
 219          ) <* R.spaces) <?> "boolean-term"
 220         where
 221                 expr =
 222                         R.lookAhead (R.try R.anyToken)
 223                         >> R.notFollowedBy (R.char ')')
 224                         >> filter_bool terms
 225
 226 parens
 227  :: Stream s m Char
 228  => ParsecT s u m a
 229  -> ParsecT s u m a
 230 parens =
 231         R.between
 232          (R.spaces >> R.char '(')
 233          (R.spaces >> R.char ')')
 234
 235 bool :: Stream s m Char => ParsecT s u m Bool
 236 bool = do
 237         R.choice_try
 238          [ R.choice_try
 239                  [ R.string "1"
 240                  , R.string "true"
 241                  , R.string "t"
 242                  ] >> return True
 243          , R.choice_try
 244                  [ R.string "0"
 245                  , R.string "false"
 246                  , R.string "f"
 247                  ] >> return False
 248          ]
 249
 250 jump :: Stream s m Char
 251  => [String]
 252  -> ParsecT s u m b
 253  -> a
 254  -> ParsecT s u m a
 255 jump prefixes next r =
 256         R.choice_try (map (\s -> R.string s >> return r) prefixes)
 257         <* R.lookAhead (R.try next)
 258
 259 -- * Read 'Filter_Account'
 260
 261 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
 262 newtype Forall_Filter_Account
 263  =      Forall_Filter_Account
 264  {  get_Forall_Filter_Account ::
 265      forall acct.
 266      ( Account acct
 267      ) => Filter_Account_Component acct
 268  }
 269
 270 filter_account
 271  :: Stream s m Char
 272  => ParsecT s Context m (Filter_Bool Forall_Filter_Account)
 273 filter_account = do
 274         f <- R.many $ R.spaces
 275                 >> R.lookAhead R.anyToken
 276                 >> filter_bool filter_account_terms
 277         return $
 278                 Data.Foldable.foldr
 279                  Filter.And
 280                  Filter.Any f
 281
 282 filter_account_terms
 283  :: Stream s m Char
 284  => [ParsecT s Context m (ParsecT s Context m (Filter_Bool Forall_Filter_Account))]
 285 filter_account_terms =
 286         [ jump [ "AT" ] filter_account_operator $ do
 287                 f <- filter_tag
 288                 return $
 289                         Bool $ Forall_Filter_Account $
 290                         Filter.Filter_Account_Tag f
 291         , return $ do
 292                 f <- filter_account_path
 293                 return $
 294                         Bool $ Forall_Filter_Account $
 295                         Filter.Filter_Account_Path f
 296         ]
 297
 298 filter_account_operator
 299  :: Stream s m Char
 300  => ParsecT s u m String
 301 filter_account_operator =
 302         R.choice_try
 303          [ filter_ord_operator
 304          ]
 305
 306 filter_account_path
 307  :: Stream s m Char
 308  => ParsecT s u m (Filter_Path Account_Section)
 309 filter_account_path = do
 310         R.notFollowedBy $ R.space_horizontal
 311         Filter_Ord o () <-
 312                 R.option (Filter_Ord Eq ()) $ R.try $
 313                         (\f -> f ()) <$> filter_ord
 314         strings <-
 315                 R.many1_separated
 316                  (R.many (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c))))
 317                  (R.char account_section_sep)
 318         sections <- forM strings $ \s ->
 319                 case s of
 320                  ""    -> return Filter_Path_Section_Many
 321                  "*"   -> return Filter_Path_Section_Any
 322                  '~':t -> Filter_Path_Section_Text . Filter_Text_Regex <$> Regex.of_StringM t
 323                  t     -> return $ Filter_Path_Section_Text $ Filter_Text_Exact $ Text.pack t
 324         return $ Filter_Path o $
 325                  (if sections == [] then [Filter_Path_Section_Many] else sections)
 326
 327 account_section_sep :: Char
 328 account_section_sep = ':'
 329
 330 -- * Read 'Filter_Amount'
 331
 332 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
 333 newtype Forall_Filter_Amount_Decimal
 334  =      Forall_Filter_Amount_Decimal
 335  {  get_Forall_Filter_Amount_Decimal ::
 336      forall amt.
 337      ( Amount amt
 338      , Amount_Quantity amt ~ Filter.Amount.Quantity
 339      ) => Filter_Amount amt
 340  }
 341
 342 filter_amount
 343  :: Stream s m Char
 344  => (Filter_Ord Filter.Amount.Quantity -> Filter_Polarized Filter.Amount.Quantity)
 345  -> ParsecT s u m Forall_Filter_Amount_Decimal
 346 filter_amount flt_polarized = do
 347         R.notFollowedBy $ R.space_horizontal
 348         R.choice_try
 349          [ filter_ord
 350                 >>= \(flt_ord::Filter.Amount.Quantity -> Filter_Ord Filter.Amount.Quantity) -> do
 351                         amt <- Amount.Read.amount
 352                         return $ Forall_Filter_Amount_Decimal $ And
 353                          (Bool $ Filter_Amount_Section_Quantity (flt_polarized $ flt_ord $ Filter.Amount.amount_quantity amt))
 354                          (case Unit.unit_text $ Filter.amount_unit amt of
 355                                  u | Text.null u -> Any
 356                                  u               -> Bool $ Filter_Amount_Section_Unit (Filter_Unit (Filter_Text_Exact u)))
 357          , filter_text
 358                 >>= \flt_ord -> do
 359                         unit_ <- Amount.Read.unit >>= flt_ord . Text.unpack . Unit.unit_text
 360                         return $ Forall_Filter_Amount_Decimal $ Bool $ Filter_Amount_Section_Unit (Filter_Unit unit_)
 361          ]
 362
 363 filter_amount_operator
 364  :: Stream s m Char
 365  => ParsecT s u m String
 366 filter_amount_operator =
 367         R.choice_try
 368          [ filter_ord_operator
 369          , filter_text_operator
 370          ]
 371
 372 -- * Read 'Filter_Date'
 373 filter_date
 374  :: (Stream s (R.Error_State Error m) Char, Monad m)
 375  => ParsecT s Context (R.Error_State Error m) (Filter_Bool Filter_Date)
 376 filter_date = do
 377         join $ R.choice_try
 378          [ R.char '=' >>
 379                 (return $ read_date_pattern)
 380          , filter_ord >>= \tst ->
 381                 return $ do
 382                         ctx <- R.getState
 383                         let (year, _, _) = Date.gregorian $ context_date ctx
 384                         liftM (Bool . Filter_Date_UTC . tst) $
 385                                 Date.Read.date Error_Filter_Date (Just year)
 386          ]
 387         where
 388                 read_date_pattern
 389                  :: (Stream s (R.Error_State Error m) Char, Monad m)
 390                  => ParsecT s u (R.Error_State Error m) (Filter_Bool Filter_Date)
 391                 read_date_pattern = (do
 392                         let read2 = of_digits <$> (R.try (R.count 2 R.digit) <|> R.count 1 R.digit)
 393                         n0 <- read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit
 394                         n1 <- R.option Nothing $ R.try $ do
 395                                 _  <- R.char '/'
 396                                 Just <$> read_interval Error_Filter_Date_Interval read2
 397                         n2 <- R.option Nothing $ R.try $ do
 398                                 _ <- R.char '/'
 399                                 Just <$> read_interval Error_Filter_Date_Interval read2
 400                         let (year, month, dom) =
 401                                 case (n1, n2) of
 402                                  (Nothing, Nothing) ->
 403                                         ( Interval.unlimited
 404                                         , n0
 405                                         , Interval.unlimited )
 406                                  (Just d1, Nothing) ->
 407                                         ( Interval.unlimited
 408                                         , n0
 409                                         , d1 )
 410                                  (Nothing, Just _d2) -> assert False undefined
 411                                  (Just d1, Just d2) ->
 412                                         ( n0
 413                                         , d1
 414                                         , d2 )
 415                         (hour, minute, second) <-
 416                                 R.option (Interval.unlimited, Interval.unlimited, Interval.unlimited) $ R.try $ do
 417                                         _ <- R.char '_'
 418                                         hour   <- read_interval Error_Filter_Date_Interval read2
 419                                         sep    <- R.char Date.Read.hour_separator
 420                                         minute <- read_interval Error_Filter_Date_Interval read2
 421                                         second <- R.option Interval.unlimited $ R.try $ do
 422                                                 _    <- R.char sep
 423                                                 read_interval Error_Filter_Date_Interval $ of_digits <$> R.many1 R.digit
 424                                         -- tz <- R.option Time.utc $ R.try $ do
 425                                         --      -- R.skipMany $ R.space_horizontal
 426                                         --      Date.Read.time_zone
 427                                         return
 428                                          ( hour
 429                                          , minute
 430                                          , second
 431                                          )
 432                         return $
 433                                 foldr And Any $
 434                                 catMaybes $
 435                                  [ just_when_limited (Filter_Date_Year   . Filter_Interval_In) year
 436                                  , just_when_limited (Filter_Date_Month  . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) month)
 437                                  , just_when_limited (Filter_Date_DoM    . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) dom)
 438                                  , just_when_limited (Filter_Date_Hour   . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) hour)
 439                                  , just_when_limited (Filter_Date_Minute . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) minute)
 440                                  , just_when_limited (Filter_Date_Second . Filter_Interval_In) (Interval.fmap_unsafe (fmap fromInteger) second)
 441                                  ]
 442                         ) <?> "date-filter"
 443                         where
 444                                 of_digits :: Num n => [Char] -> n
 445                                 of_digits = fromInteger . R.integer_of_digits 10
 446                                 just_when_limited f x =
 447                                         if x == Interval.unlimited
 448                                         then Nothing
 449                                         else Just $ Bool $ f x
 450
 451 read_interval
 452  :: (Stream s (R.Error_State e m) Char, Monad m, Ord x)
 453  => ((x, x) -> e)
 454  -> ParsecT s u (R.Error_State e m) x
 455  -> ParsecT s u (R.Error_State e m) (Interval (Interval.Unlimitable x))
 456 read_interval err read_digits = do
 457         l <- R.choice_try
 458                  [ R.string ".." >> return Interval.Unlimited_low
 459                  , Interval.Limited <$> read_digits
 460                  ]
 461         R.choice_try
 462          [ when (l /= Interval.Unlimited_low)
 463                  (void $ R.string "..") >> do
 464                 h <- R.choice_try
 465                          [ Interval.Limited <$> read_digits
 466                          , return Interval.Unlimited_high
 467                          ]
 468                 case (Interval.<=..<=) l h of
 469                  Nothing -> R.fail_with "interval" (err $ (Interval.limited l, Interval.limited h))
 470                  Just i  -> return i
 471          , return $
 472                 case l of
 473                  Interval.Limited _ -> Interval.point l
 474                  _                  -> Interval.unlimited
 475          ]
 476
 477 filter_date_operator
 478  :: Stream s m Char
 479  => ParsecT s u m String
 480 filter_date_operator =
 481         filter_ord_operator
 482
 483 -- * Read 'Filter_Wording'
 484 filter_wording
 485  :: Stream s m Char
 486  => ParsecT s u m Filter_Text
 487 filter_wording = (do
 488         make_filter_text <- filter_text
 489         R.between (R.char '"') (R.char '"') $
 490                 make_filter_text =<< (R.many $ R.try $ R.satisfy (/= '"'))
 491         ) <?> "wording"
 492
 493 filter_wording_operator
 494  :: Stream s m Char
 495  => ParsecT s u m String
 496 filter_wording_operator =
 497         filter_text_operator
 498
 499 -- * Read 'Filter_Tag'
 500 filter_tag
 501  :: Stream s m Char
 502  => ParsecT s u m Filter_Tags
 503 filter_tag = do
 504         R.notFollowedBy $ R.space_horizontal
 505         Filter_Ord o () <- (\f -> f ()) <$> filter_ord
 506         filter_tag_value <-
 507                 R.choice_try
 508                  [ R.char '<' >> return Filter_Tag_Value_First
 509                  , R.char '>' >> return Filter_Tag_Value_Last
 510                  ,               return Filter_Tag_Value_Any
 511                  ]
 512         strings <-
 513                 R.many1_separated
 514                  (R.many (R.satisfy (\c -> c /= account_section_sep && not (Data.Char.isSpace c))))
 515                  (R.char account_section_sep)
 516         sections <- forM strings $ \s ->
 517                 case s of
 518                  ""    -> return   Filter_Path_Section_Many
 519                  "*"   -> return   Filter_Path_Section_Any
 520                  '~':t ->          Filter_Path_Section_Text . Filter_Text_Regex <$> Regex.of_StringM t
 521                  t     -> return $ Filter_Path_Section_Text $ Filter_Text_Exact  $  Text.pack t
 522         case reverse sections of
 523          []  -> R.parserZero
 524          [p] -> return $ Bool $ Filter_Tag_Path $ Filter_Path o [p]
 525          value:rev_path ->
 526                 return $ And
 527                  (Bool $ Filter_Tag_Path  $ Filter_Path o $ reverse rev_path)
 528                  (Bool $ Filter_Tag_Value $ filter_tag_value $
 529                         case value of
 530                          Filter_Path_Section_Any     -> Filter_Text_Any
 531                          Filter_Path_Section_Many    -> Filter_Text_Any
 532                          Filter_Path_Section_Text ft -> ft
 533                  )
 534
 535 filter_tag_operator
 536  :: Stream s m Char
 537  => ParsecT s u m String
 538 filter_tag_operator = do
 539         void filter_ord_operator
 540         R.choice_try
 541          [ R.string "<"
 542          , R.string ">"
 543          , R.string ""
 544          ]
 545
 546 -- * Read 'Filter_Posting'
 547
 548 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
 549 newtype Forall_Filter_Posting_Decimal
 550  =      Forall_Filter_Posting_Decimal
 551  {  get_Forall_Filter_Posting_Decimal ::
 552      forall ptg.
 553      ( Posting ptg
 554      , Amount_Quantity (Posting.Posting_Amount ptg) ~ Filter.Amount.Quantity
 555      ) => Filter_Posting ptg
 556  }
 557
 558 filter_posting
 559  :: Stream s m Char
 560  => ParsecT s Context m (Filter_Bool Forall_Filter_Posting_Decimal)
 561 filter_posting =
 562         Data.Foldable.foldr Filter.And Filter.Any <$>
 563         do R.many $
 564                 R.spaces
 565                 >> R.lookAhead R.anyToken
 566                 >> filter_bool filter_posting_terms
 567
 568 filter_posting_terms
 569  :: Stream s m Char
 570  => [ParsecT s Context m (ParsecT s Context m (Filter_Bool Forall_Filter_Posting_Decimal))]
 571 filter_posting_terms =
 572         [ jump [ "a", "amount" ] filter_amount_operator $ do
 573                 f <- filter_amount Filter_Polarized_Sum
 574                 return $
 575                         Bool $ Forall_Filter_Posting_Decimal $
 576                         Filter.Filter_Posting_Amount $
 577                         get_Forall_Filter_Amount_Decimal f
 578         , jump [ "[]" ] (return ()) $ do
 579                 return $
 580                         Bool $ Forall_Filter_Posting_Decimal $
 581                         Filter_Posting_Type $
 582                         Filter_Posting_Type_Exact Posting_Type_Virtual
 583         , return $ do
 584                 f <- filter_account
 585                 return $
 586                         Bool $ Forall_Filter_Posting_Decimal $
 587                         Filter_Posting_Account $
 588                         get_Forall_Filter_Account <$> f
 589         ]
 590
 591 -- * Read 'Filter_Transaction'
 592
 593 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
 594 newtype Forall_Filter_Transaction_Decimal
 595  =      Forall_Filter_Transaction_Decimal
 596  {  get_Forall_Filter_Transaction_Decimal ::
 597      forall txn.
 598      ( Transaction txn
 599      , Amount_Quantity (Posting.Posting_Amount (Transaction_Posting txn)) ~ Filter.Amount.Quantity
 600      ) => Filter_Transaction txn
 601  }
 602
 603 filter_transaction ::
 604  ( Stream s (R.Error_State Error m) Char
 605  , Monad m
 606  ) => ParsecT s Context (R.Error_State Error m)
 607               (Filter_Bool Forall_Filter_Transaction_Decimal)
 608 filter_transaction =
 609         {-glue_posting . -}Data.Foldable.foldr Filter.And Filter.Any <$>
 610         do R.many $
 611                 R.spaces
 612                 >> R.lookAhead R.anyToken
 613                 >> filter_bool filter_transaction_terms
 614         {-
 615         where
 616                 glue_posting
 617                  :: Filter_Bool Forall_Filter_Transaction_Decimal
 618                  -> Filter_Bool Forall_Filter_Transaction_Decimal
 619                 glue_posting fb =
 620                         case fb of
 621                          Any -> Any
 622                          Bool p -> Bool p
 623                          (Or b0 b1) -> Or (glue_posting b0) (glue_posting b1)
 624                          (Not b) ->
 625                                 case glue_posting b of
 626                                  Bool f ->
 627                                         Bool $ Forall_Filter_Transaction_Decimal $
 628                                         case get_Forall_Filter_Transaction_Decimal f of
 629                                          Filter_Transaction_Posting p -> Filter_Transaction_Posting (Not p)
 630                                          x -> x
 631                                  g -> Not g
 632                          (And b0 b1) ->
 633                                 case (glue_posting b0, glue_posting b1) of
 634                                  (g0@(Bool (Forall_Filter_Transaction_Decimal f0)), g1@(Bool (Forall_Filter_Transaction_Decimal f1))) ->
 635                                         Bool $ Forall_Filter_Transaction_Decimal $
 636                                         case (f0, f1) of
 637                                          (Filter_Transaction_Posting p0, Filter_Transaction_Posting p1) ->
 638                                                 Filter_Transaction_Posting (And p0 p1)
 639                                          (x, y) -> y
 640                                  (g0@(Bool f0), g1@(Bool f1)) ->
 641                                         Bool $ Forall_Filter_Transaction_Decimal $
 642                                         case get_Forall_Filter_Transaction_Decimal f0 of
 643                                          Filter_Transaction_Posting p0 ->
 644                                                 Filter_Transaction_Posting (Not p0)
 645                                          (x) -> x
 646                                         {-
 647                                         case (get_Forall_Filter_Transaction_Decimal f0, get_Forall_Filter_Transaction_Decimal f1) of
 648                                          (Filter_Transaction_Posting p0, Filter_Transaction_Posting p1) ->
 649                                                 Filter_Transaction_Posting (And p0 p1)
 650                                          (x, y) -> x
 651                                         -}
 652                                  (g0, g1) -> And g0 g1
 653                                 {-
 654                                 case (glue_posting b0, glue_posting b1) of
 655                                  (g0@(Bool t0), g1@(Bool t1)) ->
 656                                         case (get_Forall_Filter_Transaction_Decimal t0, get_Forall_Filter_Transaction_Decimal t1) of
 657                                          (Filter_Transaction_Posting p0, Filter_Transaction_Posting p1) ->
 658                                                 Bool $ Forall_Filter_Transaction_Decimal $
 659                                                 Filter_Transaction_Posting $ Not p0
 660                                          x -> And g0 g1
 661                                  (Bool (Filter_Transaction_Posting p0), Any) ->
 662                                         Bool $
 663                                         Forall_Filter_Transaction_Decimal $
 664                                         Filter_Transaction_Posting p0
 665                                  (Any, Bool (Filter_Transaction_Posting p1)) ->
 666                                         Bool $
 667                                         Forall_Filter_Transaction_Decimal $
 668                                         Filter_Transaction_Posting p1
 669                                  (b0', b1') -> And b0' b1'
 670                                 -}
 671         -}
 672
 673 filter_transaction_terms ::
 674  ( Stream s (R.Error_State Error m) Char
 675  , Monad m
 676  ) => [ParsecT s Context (R.Error_State Error m)
 677                (ParsecT s Context (R.Error_State Error m)
 678                         (Filter_Bool Forall_Filter_Transaction_Decimal))]
 679 filter_transaction_terms =
 680         -- , jump [ "atag" ] comp_text parseFilterATag
 681         -- , jump [ "code" ] comp_text parseFilterCode
 682         [ jump [ "AT" ] filter_account_operator $ do
 683                 f <- filter_tag
 684                 return $
 685                         Bool $ Forall_Filter_Transaction_Decimal $
 686                         Filter_Transaction_Posting $
 687                         Bool $ Filter_Posting_Account $
 688                         Bool $ Filter_Account_Tag f
 689         , jump [ "date", "d" ] filter_date_operator $ do
 690                 f <- filter_date
 691                 return $
 692                         Bool $ Forall_Filter_Transaction_Decimal $
 693                         Filter.Filter_Transaction_Date f
 694         , jump [ "tag", "T" ] filter_tag_operator $ do
 695                 f <- filter_tag
 696                 return $
 697                         Bool $ Forall_Filter_Transaction_Decimal $
 698                         Filter.Filter_Transaction_Tag f
 699         , jump [ "debit", "D" ] filter_amount_operator $ do
 700                 f <- filter_amount Filter_Polarized_Positive
 701                 return $
 702                         Bool $ Forall_Filter_Transaction_Decimal $
 703                         Filter_Transaction_Posting $
 704                         Bool $ Filter_Posting_Amount $
 705                         get_Forall_Filter_Amount_Decimal f
 706         , jump [ "credit", "C" ] filter_amount_operator $ do
 707                 f <- filter_amount Filter_Polarized_Negative
 708                 return $
 709                         Bool $ Forall_Filter_Transaction_Decimal $
 710                         Filter_Transaction_Posting $
 711                         Bool $ Filter_Posting_Amount $
 712                         get_Forall_Filter_Amount_Decimal f
 713         , jump [ "wording", "W" ] filter_wording_operator $ do
 714                 f <- filter_wording
 715                 return $
 716                         Bool $ Forall_Filter_Transaction_Decimal $
 717                         Filter.Filter_Transaction_Wording f
 718         , return $ do
 719                 f <- filter_account
 720                 return $
 721                         Bool $ Forall_Filter_Transaction_Decimal $
 722                         Filter_Transaction_Posting $
 723                         Bool $ Filter_Posting_Account $
 724                         get_Forall_Filter_Account <$> f
 725                 {-
 726         -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
 727         -- , jump [ "real" ] (R.char '=') parseFilterReal
 728         -- , jump [ "status" ] (R.char '=') parseFilterStatus
 729         -- , jump [ "sym" ] comp_text parseFilterSym
 730         -- , R.lookAhead comp_num >> return parseFilterAmount
 731                 -}
 732         ]
 733
 734 -- * Read 'Filter_Balance'
 735
 736 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
 737 newtype Forall_Filter_Balance_Decimal
 738  =      Forall_Filter_Balance_Decimal
 739  {  get_Forall_Filter_Balance_Decimal ::
 740      forall txn.
 741      ( Balance txn
 742      , Amount_Quantity (Balance_Amount txn) ~ Filter.Amount.Quantity
 743      ) => Filter_Balance txn
 744  }
 745
 746 filter_balance
 747  :: Stream s m Char
 748  => ParsecT s Context m (Filter_Bool Forall_Filter_Balance_Decimal)
 749 filter_balance =
 750         Data.Foldable.foldr Filter.And Filter.Any <$>
 751         do R.many $
 752                 R.spaces
 753                 >> R.lookAhead R.anyToken
 754                 >> filter_bool filter_balance_terms
 755
 756 filter_balance_terms
 757  :: Stream s m Char
 758  => [ParsecT s Context m (ParsecT s Context m (Filter_Bool Forall_Filter_Balance_Decimal))]
 759 filter_balance_terms =
 760         [ jump [ "AT" ] filter_account_operator $ do
 761                 f <- filter_tag
 762                 return $
 763                         Bool $ Forall_Filter_Balance_Decimal $
 764                         Filter_Balance_Account $
 765                         Bool $ Filter_Account_Tag f
 766         , jump [ "RD", "debit" ] filter_amount_operator $ do
 767                 f <- filter_amount Filter_Polarized_Positive
 768                 return $
 769                         Bool $ Forall_Filter_Balance_Decimal $
 770                         Filter_Balance_Amount $
 771                         get_Forall_Filter_Amount_Decimal f
 772         , jump [ "RC", "credit" ] filter_amount_operator $ do
 773                 f <- filter_amount Filter_Polarized_Negative
 774                 return $
 775                         Bool $ Forall_Filter_Balance_Decimal $
 776                         Filter_Balance_Amount $
 777                         get_Forall_Filter_Amount_Decimal f
 778         , jump [ "RB", "balance" ] filter_amount_operator $ do
 779                 f <- filter_amount Filter_Polarized_Sum
 780                 return $
 781                         Bool $ Forall_Filter_Balance_Decimal $
 782                         Filter_Balance_Amount $
 783                         get_Forall_Filter_Amount_Decimal f
 784         , return $ do
 785                 f <- filter_account
 786                 return $
 787                         Bool $ Forall_Filter_Balance_Decimal $
 788                         Filter_Balance_Account $
 789                         get_Forall_Filter_Account <$> f
 790         ]
 791
 792 -- * Read 'Filter_GL'
 793
 794 -- | A forall type (Rank2Types) to preserve the polymorphism of the filter.
 795 newtype Forall_Filter_GL_Decimal
 796  =      Forall_Filter_GL_Decimal
 797  {  get_Forall_Filter_GL_Decimal ::
 798      forall txn.
 799      ( GL txn
 800      , Amount_Quantity (GL_Amount txn) ~ Filter.Amount.Quantity
 801      ) => Filter_GL txn
 802  }
 803
 804 filter_gl
 805  :: Stream s m Char
 806  => ParsecT s Context m (Filter_Bool Forall_Filter_GL_Decimal)
 807 filter_gl =
 808         Data.Foldable.foldr Filter.And Filter.Any <$>
 809         do R.many $
 810                 R.spaces
 811                 >> R.lookAhead R.anyToken
 812                 >> filter_bool filter_gl_terms
 813
 814 filter_gl_terms
 815  :: Stream s m Char
 816  => [ParsecT s Context m (ParsecT s Context m (Filter_Bool Forall_Filter_GL_Decimal))]
 817 filter_gl_terms =
 818         [ jump [ "AT" ] filter_account_operator $ do
 819                 f <- filter_tag
 820                 return $
 821                         Bool $ Forall_Filter_GL_Decimal $
 822                         Filter_GL_Account $
 823                         Bool $ Filter_Account_Tag f
 824         , jump [ "D", "debit" ] filter_amount_operator $ do
 825                 f <- filter_amount Filter_Polarized_Positive
 826                 return $
 827                         Bool $ Forall_Filter_GL_Decimal $
 828                         Filter_GL_Amount $
 829                         get_Forall_Filter_Amount_Decimal f
 830         , jump [ "C", "credit" ] filter_amount_operator $ do
 831                 f <- filter_amount Filter_Polarized_Negative
 832                 return $
 833                         Bool $ Forall_Filter_GL_Decimal $
 834                         Filter_GL_Amount $
 835                         get_Forall_Filter_Amount_Decimal f
 836         , jump [ "B", "balance" ] filter_amount_operator $ do
 837                 f <- filter_amount Filter_Polarized_Sum
 838                 return $
 839                         Bool $ Forall_Filter_GL_Decimal $
 840                         Filter_GL_Amount $
 841                         get_Forall_Filter_Amount_Decimal f
 842         , jump [ "RD", "running-debit" ] filter_amount_operator $ do
 843                 f <- filter_amount Filter_Polarized_Positive
 844                 return $
 845                         Bool $ Forall_Filter_GL_Decimal $
 846                         Filter_GL_Sum $
 847                         get_Forall_Filter_Amount_Decimal f
 848         , jump [ "RC", "running-credit" ] filter_amount_operator $ do
 849                 f <- filter_amount Filter_Polarized_Negative
 850                 return $
 851                         Bool $ Forall_Filter_GL_Decimal $
 852                         Filter_GL_Sum $
 853                         get_Forall_Filter_Amount_Decimal f
 854         , jump [ "RB", "running-balance" ] filter_amount_operator $ do
 855                 f <- filter_amount Filter_Polarized_Sum
 856                 return $
 857                         Bool $ Forall_Filter_GL_Decimal $
 858                         Filter_GL_Sum $
 859                         get_Forall_Filter_Amount_Decimal f
 860         , return $ do
 861                 f <- filter_account
 862                 return $
 863                         Bool $ Forall_Filter_GL_Decimal $
 864                         Filter_GL_Account $
 865                         get_Forall_Filter_Account <$> f
 866         ]