lib/Hcompta/Account/Read.hs

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