lib/Hcompta/Model/Filter/Read.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 module Hcompta.Model.Filter.Read where
   4
   5 import           Prelude hiding (filter)
   6 import           Control.Applicative ((<$>){-, (<*>)-}, (<*))
   7 import           Control.Monad (liftM)
   8 -- import           Control.Monad.Trans.Except (ExceptT(..), throwE)
   9 import qualified Data.Char
  10 import           Data.Data
  11 import qualified Data.Foldable
  12 import           Data.Functor.Identity (Identity)
  13 import qualified Text.Parsec.Expr as R
  14 import qualified Text.Parsec as R hiding
  15                   ( char
  16                   , anyChar
  17                   , crlf
  18                   , newline
  19                   , noneOf
  20                   , oneOf
  21                   , satisfy
  22                   , space
  23                   , spaces
  24                   , string
  25                   )
  26 -- import qualified Text.Parsec.Expr as R
  27 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  28 import           Data.String (fromString)
  29 import qualified Data.Text as Text
  30 import           Data.Text (Text)
  31 import           Data.Typeable ()
  32
  33 import qualified Hcompta.Lib.Regex as Regex
  34 -- import           Hcompta.Lib.Regex (Regex)
  35 import qualified Hcompta.Model.Account as Account
  36 import qualified Hcompta.Model.Filter as Filter
  37 import           Hcompta.Model.Filter
  38                   ( -- Filter(..)
  39                     Test_Account
  40                   , Test_Account_Section(..)
  41                   , Test_Bool(..)
  42                   , Test_Num_Abs(..)
  43                   , Test_Ord(..)
  44                   , Test_Posting(..)
  45                   , Test_Text(..)
  46                   , Test_Transaction(..)
  47                   , Test_Balance(..)
  48                   )
  49 import qualified Hcompta.Lib.Parsec as R
  50
  51 -- * Parsers' types
  52
  53 -- ** Type 'Context'
  54
  55 data Context
  56  =   Context
  57  {
  58  } deriving (Data, Eq, Show, Typeable)
  59
  60 context :: Context
  61 context = Context
  62
  63 -- ** Type 'Error'
  64
  65 data Error
  66  =   Error_Unknown
  67  deriving (Eq, Show)
  68
  69 -- * Parsers
  70
  71 -- ** Parse 'Test_Text'
  72 test_text
  73  :: (Stream s m Char, Monad r)
  74  => ParsecT s u m (String -> r Test_Text)
  75 test_text =
  76         R.choice_try
  77          [ R.char '~' >> return (\s -> Regex.of_StringM s >>= (return . Test_Text_Regex))
  78          , R.char '=' >> return (\s -> return (Test_Text_Exact $ Text.pack s))
  79          ,               return (\s -> return (Test_Text_Exact $ Text.pack s))
  80          ]
  81
  82 -- ** Parse 'Test_Ord'
  83 test_ord
  84  :: (Stream s m Char, Ord o)
  85  => ParsecT s u m (o -> m (Test_Ord o))
  86 test_ord =
  87         R.choice_try
  88          [ R.string "="  >> return (return . Test_Ord_Eq)
  89          , R.string "<=" >> return (return . Test_Ord_Lt_Eq)
  90          , R.string ">=" >> return (return . Test_Ord_Gt_Eq)
  91          , R.string "<"  >> return (return . Test_Ord_Lt)
  92          , R.string ">"  >> return (return . Test_Ord_Gt)
  93          ]
  94
  95 -- ** Parse 'Test_Num_Abs'
  96 test_num_abs
  97  :: (Stream s m Char, Num n)
  98  => ParsecT s u m (Test_Ord n -> m (Either (Test_Ord n) (Test_Num_Abs n)))
  99 test_num_abs =
 100         R.choice_try
 101          [ R.char '+' >> return (return . Right . Test_Num_Abs)
 102          , return (return . Left)
 103          ]
 104
 105 text :: Stream s m Char => String -> ParsecT s Context m Text
 106 text none_of =
 107         fromString <$>
 108         R.choice_try
 109          [ borders inside
 110          , R.many $ R.noneOf ("() " ++ none_of)
 111          ]
 112         where
 113                 borders = R.between (R.char '(') (R.char ')')
 114                 inside = liftM concat $ R.many (R.choice_try [borders preserve_inside, R.many1 $ R.noneOf "()"])
 115                 preserve_inside = inside >>= (\x -> return $ '(':(x++')':[]))
 116
 117 -- ** Parse 'Test_Bool'
 118
 119 test_bool
 120  :: (Stream s m Char)
 121  => [ParsecT s Context m (ParsecT s Context m t)]
 122  -> ParsecT s Context m (Test_Bool t)
 123 test_bool terms =
 124         R.buildExpressionParser
 125          test_bool_operators
 126          (test_bool_term terms)
 127         <?> "test_bool"
 128
 129 test_bool_operators
 130  :: Stream s m Char
 131  => R.OperatorTable s u m (Filter.Test_Bool t)
 132 test_bool_operators =
 133         [ [ prefix "- "   Filter.Not
 134           , prefix "not " Filter.Not
 135           ]
 136         , [ binary " & "   Filter.And                     R.AssocLeft
 137           , binary " and " Filter.And                     R.AssocLeft
 138           , binary " - "   (flip Filter.And . Filter.Not) R.AssocLeft
 139           , binary " but " (flip Filter.And . Filter.Not) R.AssocLeft
 140           ]
 141         , [ binary " + "  Filter.Or R.AssocLeft
 142           , binary " or " Filter.Or R.AssocLeft
 143           ]
 144         ]
 145         where
 146                 binary  name fun assoc = R.Infix  (test_bool_operator name >> return fun) assoc
 147                 prefix  name fun       = R.Prefix (test_bool_operator name >> return fun)
 148                 -- postfix name fun       = Text.Parsec.Expr.Postfix (test_bool_operator name >> return fun)
 149
 150 test_bool_operator
 151  :: Stream s m Char
 152  => String -> ParsecT s u m ()
 153 test_bool_operator name =
 154         lexeme $ R.try $
 155                 (R.string name
 156                 >> R.notFollowedBy test_bool_operator_letter
 157                 <?> ("end of " ++ show name))
 158
 159 test_bool_operator_letter
 160  :: Stream s m Char => ParsecT s u m Char
 161 test_bool_operator_letter =
 162         R.oneOf ['+', '-', '&']
 163
 164 test_bool_term
 165  :: Stream s m Char
 166  => [ParsecT s Context m (ParsecT s Context m t)]
 167  ->  ParsecT s Context m (Test_Bool t)
 168 test_bool_term terms = do
 169         r <- R.choice_try
 170          ( (R.lookAhead (R.try $ R.char '(')
 171                 >> (return $ parens $
 172                         Data.Foldable.foldr Filter.And Filter.Any <$>
 173                         R.many (R.spaces >> expr) ))
 174          : map ((Filter.Bool <$>) <$>) terms
 175          ) <* R.spaces <?> "filter expression"
 176         r
 177         where
 178                 expr =
 179                         R.lookAhead (R.try R.anyToken)
 180                         >> R.notFollowedBy (R.char ')')
 181                         >> test_bool terms
 182
 183 lexeme
 184  :: Stream s m Char
 185  => ParsecT s u m a -> ParsecT s u m a
 186 lexeme p = p <* R.spaces
 187
 188 parens
 189  :: Stream s m Char
 190  => ParsecT s u m a -> ParsecT s u m a
 191 parens = R.between (lexeme $ R.char '(') (lexeme $ R.char ')')
 192
 193 bool :: Stream s m Char => ParsecT s u m Bool
 194 bool = do
 195         R.choice_try
 196          [ R.choice_try
 197                  [ R.string "1"
 198                  , R.string "true"
 199                  , R.string "t"
 200                  ] >> return True
 201          , R.choice_try
 202                  [ R.string "0"
 203                  , R.string "false"
 204                  , R.string "f"
 205                  ] >> return False
 206          ]
 207
 208 -- ** Parse Account.'Account.Name'
 209 account_name :: Stream s m Char => ParsecT s u m Account.Name
 210 account_name = do
 211         fromString <$> do
 212         R.many1 $ R.try account_name_char
 213         where
 214                 account_name_char :: Stream s m Char => ParsecT s u m Char
 215                 account_name_char = do
 216                         c <- R.anyChar
 217                         case c of
 218                          -- _ | c == comment_begin -> R.parserZero
 219                          -- _ | c == account_name_sep -> R.parserZero
 220                          _ | R.is_space_horizontal c -> do
 221                                 _ <- R.notFollowedBy $ R.space_horizontal
 222                                 return c <* (R.lookAhead $ R.try $
 223                                  ( R.try (R.char account_name_sep)
 224                                  <|> account_name_char
 225                                  ))
 226                          _ | not (Data.Char.isSpace c) -> return c
 227                          _ -> R.parserZero
 228
 229 -- ** Parse 'Test_Account_Section'
 230 test_account_section
 231  :: (Stream s m Char)
 232  => (String -> ParsecT s u m Test_Text)
 233  -> ParsecT s u m Test_Account_Section
 234 test_account_section make_test_text = do
 235         R.choice_try
 236          [ R.char '*'
 237                  <* R.lookAhead account_name_sep_or_eof
 238                  >> return Test_Account_Section_Any
 239          , R.many1 (R.satisfy (\c -> c /= account_name_sep && not (Data.Char.isSpace c)))
 240                  >>= (liftM Test_Account_Section_Text . make_test_text)
 241          , R.lookAhead account_name_sep_or_eof
 242                  >> R.many (R.try (R.char account_name_sep
 243                          >> R.lookAhead account_name_sep_or_eof))
 244                  >> return Test_Account_Section_Skip
 245          ]
 246         where
 247                 account_name_sep_or_eof =
 248                         (R.try (R.char account_name_sep) >> return ())
 249                         <|> R.eof
 250
 251 -- ** Parse 'Test_Account'
 252 account_name_sep :: Char
 253 account_name_sep = ':'
 254
 255 test_account
 256  :: Stream s m Char
 257  => ParsecT s u m Test_Account
 258 test_account = do
 259         R.notFollowedBy $ R.space_horizontal
 260         make_test_text <- test_text
 261         R.many1_separated (test_account_section make_test_text) $
 262                 R.char account_name_sep
 263
 264 -- ** Parse 'Test_Posting'
 265 test_posting
 266  :: (Stream s m Char, Filter.Posting t)
 267  => ParsecT s Context m (Test_Bool (Test_Posting t))
 268 test_posting =
 269         Data.Foldable.foldr Filter.And Filter.Any <$>
 270         do R.many $
 271                 R.spaces
 272                 >> R.lookAhead R.anyToken
 273                 >> test_bool test_posting_terms
 274
 275 test_posting_terms
 276  :: (Stream s m Char, Filter.Posting t)
 277  => [ParsecT s Context m (ParsecT s Context m (Test_Posting t))]
 278 test_posting_terms =
 279         [ return
 280                 ( Filter.Test_Posting_Account
 281                 <$> test_account )
 282         ]
 283
 284 -- ** Parse 'Test_Transaction'
 285 test_transaction
 286  :: (Stream s m Char, Filter.Transaction t)
 287  => ParsecT s Context m (Test_Bool (Test_Transaction t))
 288 test_transaction =
 289         Data.Foldable.foldr Filter.And Filter.Any <$>
 290         do R.many $
 291                 R.spaces
 292                 >> R.lookAhead R.anyToken
 293                 >> test_bool test_transaction_terms
 294
 295 test_transaction_terms
 296  :: (Stream s m Char, Filter.Transaction t)
 297  => [ParsecT s Context m (ParsecT s Context m (Test_Transaction t))]
 298 test_transaction_terms =
 299         [ return
 300                 ( Filter.Test_Transaction_Posting
 301                 . Filter.Test_Posting_Account
 302                 <$> test_account )
 303         -- , jump [ "account","acct" ] comp_text test_account
 304         -- , jump [ "amount", "amt" ] comp_num parseFilterAmount
 305         -- , jump [ "atag" ] comp_text parseFilterATag
 306         -- , jump [ "balance", "bal" ] comp_num parseFilterBalance
 307         -- , jump [ "code" ] comp_text parseFilterCode
 308         -- , jump [ "date" ] (R.char '=') parseFilterDate
 309         -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
 310         -- , jump [ "depth" ] comp_num parseFilterDepth
 311         -- , jump [ "description","descr","desc" ] comp_text parseFilterDesc
 312         -- , jump [ "real" ] (R.char '=') parseFilterReal
 313         -- , jump [ "status" ] (R.char '=') parseFilterStatus
 314         -- , jump [ "sym" ] comp_text parseFilterSym
 315         -- , jump [ "tag" ] comp_text parseFilterTag
 316         -- , R.lookAhead comp_num >> return parseFilterAmount
 317         ]
 318         -- where
 319                 -- jump :: Stream s m Char => [String] -> ParsecT s u m b -> a -> ParsecT s u m a
 320                 -- jump l next r =
 321                 --      R.choice_try
 322                 --       (map (\s -> R.string s >> return r) l)
 323                 --       <* R.lookAhead next
 324
 325 -- ** Parse 'Test_Balance'
 326 test_balance
 327  :: (Stream s m Char, Filter.Balance t)
 328  => ParsecT s Context m (Test_Bool (Test_Balance t))
 329 test_balance =
 330         Data.Foldable.foldr Filter.And Filter.Any <$>
 331         do R.many $
 332                 R.spaces
 333                 >> R.lookAhead R.anyToken
 334                 >> test_bool test_balance_terms
 335
 336 test_balance_terms
 337  :: (Stream s m Char, Filter.Balance t)
 338  => [ParsecT s Context m (ParsecT s Context m (Test_Balance t))]
 339 test_balance_terms =
 340         [ return
 341                 ( Filter.Test_Balance_Account
 342                 <$> test_account )
 343         ]
 344
 345 -- * Parsing
 346 read ::
 347  ( Stream s (R.Error_State Error Identity) Char
 348  , Show t
 349  )
 350  => ParsecT s Context (R.Error_State Error Identity) (Test_Bool t)
 351  -> s -> Either [R.Error Error] (Test_Bool t)
 352 read t s =
 353         R.runParser_with_Error t context "" s
 354
 355 {-
 356
 357 account :: Stream s m Char => ParsecT s Context m Filter
 358 account = do
 359         o <- R.optionMaybe comp_text
 360         liftM (Filter.Account $ fromMaybe Comp_Text_Exact o)
 361          (liftM (accountNameComponents) $ string (" \t"++"+-&"))
 362
 363 parseFilterAmount :: Stream s m Char => ParsecT s Context m Filter
 364 parseFilterAmount = do
 365         Filter.Amount
 366          <$> comp_num
 367          <*> comp_num_abs
 368          <*> amount
 369
 370 parseFilterATag :: Stream s m Char => ParsecT s Context m Filter
 371 parseFilterATag = do
 372         c <- comp_text
 373         liftM (uncurry (ATag c))
 374          parseTag
 375
 376 --parseFilterCode :: Stream s m Char => ParsecT s Context m Filter
 377 --parseFilterCode = do
 378 --      string "code="
 379 --      liftM Code $
 380 --       try (do {
 381                 --              choice
 382                 --               [ inparen
 383                 --               , R.many nonspace
 384                 --               ]
 385                 --              return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
 386                 --       })
 387
 388 parseFilterBalance :: Stream s m Char => ParsecT s Context m Filter
 389 parseFilterBalance = do
 390         nc <- comp_num
 391         absc <- comp_num_abs
 392         a <- parseAmount Nothing
 393         return $ Bal (nc, absc) a
 394
 395 parseFilterDate :: Stream s m Char => ParsecT s Context m Filter
 396 parseFilterDate = do
 397         R.char '='
 398         ctx <- getState
 399         liftM Date $
 400          periodexprdatespan (qCtxDay ctx)
 401
 402 parseFilterDate2 :: Stream s m Char => ParsecT s Context m Filter
 403 parseFilterDate2 = do
 404         R.char '='
 405         ctx <- getState
 406         liftM Date2 $
 407          periodexprdatespan (qCtxDay ctx)
 408
 409 parseFilterDesc :: Stream s m Char => ParsecT s Context m Filter
 410 parseFilterDesc = do
 411         c <- comp_text
 412         liftM (Desc c)
 413          (string "")
 414
 415 parseFilterDepth :: Stream s m Char => ParsecT s Context m Filter
 416 parseFilterDepth = do
 417         c <- comp_num
 418         liftM (Depth c . fromIntegral) $
 419          parseDecimal
 420
 421 parseFilterReal :: Stream s m Char => ParsecT s Context m Filter
 422 parseFilterReal = do
 423         R.char '='
 424         liftM Real bool
 425
 426 -- | Parse the boolean value part of a "status:" query, allowing "*" as
 427 -- another way to spell True, similar to the journal file format.
 428 parseFilterStatus :: Stream s m Char => ParsecT s Context m Filter
 429 parseFilterStatus = do
 430         R.char '='
 431         liftM Status $
 432          try (R.char '*' >> return True) <|> bool
 433
 434 --parseFilterSym :: Stream s m Char => ParsecT s Context m Filter
 435 --parseFilterSym = do
 436 --      string "cur="
 437 --      liftM Sym
 438 --       commoditysymbol
 439
 440 parseFilterTag :: Stream s m Char => ParsecT s Context m Filter
 441 parseFilterTag = do
 442         c <- comp_text
 443         liftM (uncurry (Tag c))
 444          parseTag
 445 -}