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 -- * Reading
  70
  71 -- ** Read '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 -- ** Read '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 -- ** Read '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 -- ** Read '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 -- ** Read 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 -- ** Read '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_section_end
 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_section_end
 242                  >> R.many (R.try (R.char account_name_sep >> R.lookAhead (R.try account_section_end)))
 243                  >> return Test_Account_Section_Many
 244          ]
 245         where
 246                 account_section_end =
 247                         R.choice_try
 248                          [ R.char account_name_sep >> return ()
 249                          , R.space_horizontal >> return ()
 250                          , R.eof
 251                          ]
 252
 253 -- ** Read 'Test_Account'
 254 account_name_sep :: Char
 255 account_name_sep = ':'
 256
 257 test_account
 258  :: Stream s m Char
 259  => ParsecT s u m Test_Account
 260 test_account = do
 261         R.notFollowedBy $ R.space_horizontal
 262         make_test_text <- test_text
 263         R.many1_separated (test_account_section make_test_text) $
 264                 R.char account_name_sep
 265
 266 -- ** Read 'Test_Posting'
 267 test_posting
 268  :: (Stream s m Char, Filter.Posting t)
 269  => ParsecT s Context m (Test_Bool (Test_Posting t))
 270 test_posting =
 271         Data.Foldable.foldr Filter.And Filter.Any <$>
 272         do R.many $
 273                 R.spaces
 274                 >> R.lookAhead R.anyToken
 275                 >> test_bool test_posting_terms
 276
 277 test_posting_terms
 278  :: (Stream s m Char, Filter.Posting t)
 279  => [ParsecT s Context m (ParsecT s Context m (Test_Posting t))]
 280 test_posting_terms =
 281         [ return
 282                 ( Filter.Test_Posting_Account
 283                 <$> test_account )
 284         ]
 285
 286 -- ** Read 'Test_Transaction'
 287 test_transaction
 288  :: (Stream s m Char, Filter.Transaction t)
 289  => ParsecT s Context m (Test_Bool (Test_Transaction t))
 290 test_transaction =
 291         Data.Foldable.foldr Filter.And Filter.Any <$>
 292         do R.many $
 293                 R.spaces
 294                 >> R.lookAhead R.anyToken
 295                 >> test_bool test_transaction_terms
 296
 297 test_transaction_terms
 298  :: (Stream s m Char, Filter.Transaction t)
 299  => [ParsecT s Context m (ParsecT s Context m (Test_Transaction t))]
 300 test_transaction_terms =
 301         [ return
 302                 ( Filter.Test_Transaction_Posting
 303                 . Filter.Test_Posting_Account
 304                 <$> test_account )
 305         -- , jump [ "account","acct" ] comp_text test_account
 306         -- , jump [ "amount", "amt" ] comp_num parseFilterAmount
 307         -- , jump [ "atag" ] comp_text parseFilterATag
 308         -- , jump [ "balance", "bal" ] comp_num parseFilterBalance
 309         -- , jump [ "code" ] comp_text parseFilterCode
 310         -- , jump [ "date" ] (R.char '=') parseFilterDate
 311         -- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
 312         -- , jump [ "depth" ] comp_num parseFilterDepth
 313         -- , jump [ "description","descr","desc" ] comp_text parseFilterDesc
 314         -- , jump [ "real" ] (R.char '=') parseFilterReal
 315         -- , jump [ "status" ] (R.char '=') parseFilterStatus
 316         -- , jump [ "sym" ] comp_text parseFilterSym
 317         -- , jump [ "tag" ] comp_text parseFilterTag
 318         -- , R.lookAhead comp_num >> return parseFilterAmount
 319         ]
 320         -- where
 321                 -- jump :: Stream s m Char => [String] -> ParsecT s u m b -> a -> ParsecT s u m a
 322                 -- jump l next r =
 323                 --      R.choice_try
 324                 --       (map (\s -> R.string s >> return r) l)
 325                 --       <* R.lookAhead next
 326
 327 -- ** Read 'Test_Balance'
 328 test_balance
 329  :: (Stream s m Char, Filter.Balance t)
 330  => ParsecT s Context m (Test_Bool (Test_Balance t))
 331 test_balance =
 332         Data.Foldable.foldr Filter.And Filter.Any <$>
 333         do R.many $
 334                 R.spaces
 335                 >> R.lookAhead R.anyToken
 336                 >> test_bool test_balance_terms
 337
 338 test_balance_terms
 339  :: (Stream s m Char, Filter.Balance t)
 340  => [ParsecT s Context m (ParsecT s Context m (Test_Balance t))]
 341 test_balance_terms =
 342         [ return
 343                 ( Filter.Test_Balance_Account
 344                 <$> test_account )
 345         ]
 346
 347 -- * Parsing
 348 read ::
 349  ( Stream s (R.Error_State Error Identity) Char
 350  , Show t
 351  )
 352  => ParsecT s Context (R.Error_State Error Identity) (Test_Bool t)
 353  -> s -> Either [R.Error Error] (Test_Bool t)
 354 read t s =
 355         R.runParser_with_Error t context "" s
 356
 357 {-
 358
 359 account :: Stream s m Char => ParsecT s Context m Filter
 360 account = do
 361         o <- R.optionMaybe comp_text
 362         liftM (Filter.Account $ fromMaybe Comp_Text_Exact o)
 363          (liftM (accountNameComponents) $ string (" \t"++"+-&"))
 364
 365 parseFilterAmount :: Stream s m Char => ParsecT s Context m Filter
 366 parseFilterAmount = do
 367         Filter.Amount
 368          <$> comp_num
 369          <*> comp_num_abs
 370          <*> amount
 371
 372 parseFilterATag :: Stream s m Char => ParsecT s Context m Filter
 373 parseFilterATag = do
 374         c <- comp_text
 375         liftM (uncurry (ATag c))
 376          parseTag
 377
 378 --parseFilterCode :: Stream s m Char => ParsecT s Context m Filter
 379 --parseFilterCode = do
 380 --      string "code="
 381 --      liftM Code $
 382 --       try (do {
 383                 --              choice
 384                 --               [ inparen
 385                 --               , R.many nonspace
 386                 --               ]
 387                 --              return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
 388                 --       })
 389
 390 parseFilterBalance :: Stream s m Char => ParsecT s Context m Filter
 391 parseFilterBalance = do
 392         nc <- comp_num
 393         absc <- comp_num_abs
 394         a <- parseAmount Nothing
 395         return $ Bal (nc, absc) a
 396
 397 parseFilterDate :: Stream s m Char => ParsecT s Context m Filter
 398 parseFilterDate = do
 399         R.char '='
 400         ctx <- getState
 401         liftM Date $
 402          periodexprdatespan (qCtxDay ctx)
 403
 404 parseFilterDate2 :: Stream s m Char => ParsecT s Context m Filter
 405 parseFilterDate2 = do
 406         R.char '='
 407         ctx <- getState
 408         liftM Date2 $
 409          periodexprdatespan (qCtxDay ctx)
 410
 411 parseFilterDesc :: Stream s m Char => ParsecT s Context m Filter
 412 parseFilterDesc = do
 413         c <- comp_text
 414         liftM (Desc c)
 415          (string "")
 416
 417 parseFilterDepth :: Stream s m Char => ParsecT s Context m Filter
 418 parseFilterDepth = do
 419         c <- comp_num
 420         liftM (Depth c . fromIntegral) $
 421          parseDecimal
 422
 423 parseFilterReal :: Stream s m Char => ParsecT s Context m Filter
 424 parseFilterReal = do
 425         R.char '='
 426         liftM Real bool
 427
 428 -- | Read the boolean value part of a "status:" query, allowing "*" as
 429 -- another way to spell True, similar to the journal file format.
 430 parseFilterStatus :: Stream s m Char => ParsecT s Context m Filter
 431 parseFilterStatus = do
 432         R.char '='
 433         liftM Status $
 434          try (R.char '*' >> return True) <|> bool
 435
 436 --parseFilterSym :: Stream s m Char => ParsecT s Context m Filter
 437 --parseFilterSym = do
 438 --      string "cur="
 439 --      liftM Sym
 440 --       commoditysymbol
 441
 442 parseFilterTag :: Stream s m Char => ParsecT s Context m Filter
 443 parseFilterTag = do
 444         c <- comp_text
 445         liftM (uncurry (Tag c))
 446          parseTag
 447 -}