ledger/Hcompta/Format/Ledger/Account/Read.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE TupleSections #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 module Hcompta.Format.Ledger.Account.Read where
   8
   9 import           Control.Applicative ((<$>), (<*))
  10 import           Control.Monad (Monad(..))
  11 import           Data.Bool
  12 import           Data.Char
  13 import           Data.Eq (Eq(..))
  14 import           Data.Maybe (Maybe(..))
  15 import           Data.String (fromString)
  16 import           Data.Typeable ()
  17 import           Data.Text (Text)
  18 import           Prelude (($), (.))
  19 import qualified Text.Parsec as R hiding
  20                   ( char
  21                   , anyChar
  22                   , crlf
  23                   , newline
  24                   , noneOf
  25                   , oneOf
  26                   , satisfy
  27                   , space
  28                   , spaces
  29                   , string
  30                   , tab
  31                   )
  32 import           Text.Parsec (Stream, ParsecT, (<|>))
  33
  34 import qualified Hcompta.Account as Account
  35 import qualified Hcompta.Format.Ledger as Ledger
  36 import           Hcompta.Format.Ledger ( Account_Joker
  37                                        , Account_Joker_Section(..)
  38                                        , Account_Pattern(..)
  39                                        )
  40 import qualified Hcompta.Lib.Regex as Regex
  41 import           Hcompta.Lib.Regex (Regex)
  42 import qualified Hcompta.Lib.Parsec as R
  43
  44 -- * Read 'Account'
  45
  46 section_sep :: Char
  47 section_sep = ':'
  48
  49 -- | Read an 'Account'.
  50 account :: Stream s m Char => ParsecT s u m Ledger.Account
  51 account = do
  52         R.notFollowedBy $ R.space_horizontal
  53         Account.from_List <$> do
  54         R.many1_separated section $ R.char section_sep
  55
  56 -- | Read an Account.'Account.Account_Section'.
  57 comment_begin :: Char
  58 comment_begin = ';'
  59
  60 section :: Stream s m Char => ParsecT s u m Text
  61 section = do
  62         fromString <$> do
  63         R.many1 $ R.try account_name_char
  64         where
  65                 account_name_char :: Stream s m Char => ParsecT s u m Char
  66                 account_name_char = do
  67                         c <- R.anyChar
  68                         case c of
  69                          _ | c == comment_begin -> R.parserZero
  70                          _ | c == section_sep -> R.parserZero
  71                          _ | c /= '\t' && R.is_space_horizontal c -> do
  72                                 _ <- R.notFollowedBy $ R.space_horizontal
  73                                 return c <* (R.lookAhead $ R.try $
  74                                  ( R.try (R.char section_sep)
  75                                  <|> account_name_char
  76                                  ))
  77                          _ | not (Data.Char.isSpace c) -> return c
  78                          _ -> R.parserZero
  79
  80 -- | Read an 'Account_Joker_Section'.
  81 joker_section :: Stream s m Char => ParsecT s u m Account_Joker_Section
  82 joker_section = do
  83         n <- R.option Nothing $ (Just <$> section)
  84         case n of
  85          Nothing -> R.char section_sep >> (return $ Account_Joker_Any)
  86          Just n' -> return $ Account_Joker_Section n'
  87
  88 -- | Read an 'Account_Joker'.
  89 joker :: Stream s m Char => ParsecT s u m Account_Joker
  90 joker = do
  91         R.notFollowedBy $ R.space_horizontal
  92         R.many1_separated joker_section $ R.char section_sep
  93
  94 -- | Read a 'Regex'.
  95 regex :: Stream s m Char => ParsecT s u m Regex
  96 regex = do
  97         re <- R.many1 $ R.satisfy (not . R.is_space_horizontal)
  98         Regex.of_StringM re
  99
 100 -- | Read an 'Account_Filter'.
 101 pattern :: Stream s m Char => ParsecT s u m Account_Pattern
 102 pattern = do
 103         R.choice_try
 104          [ Account_Pattern_Exact <$> (R.char '=' >> account)
 105          , Account_Pattern_Joker <$> (R.char '*' >> joker)
 106          , Account_Pattern_Regex <$> (R.option '~' (R.char '~') >> regex)
 107          ]