lib/Hcompta/Format/Ledger/Read.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 module Hcompta.Format.Ledger.Read where
   6
   7 import           Control.Applicative ((<*), (<$>))
   8 import qualified Control.Exception as Exn
   9 import           Control.Monad (guard)
  10 -- import           Control.Monad.Error
  11 import qualified Data.Char
  12 import           Data.Data
  13 import qualified Data.Decimal
  14 import qualified Data.List
  15 -- import           Data.List.Split (wordsBy)
  16 import qualified Data.Map
  17 import           Data.Maybe
  18 import qualified Data.Time.Calendar  as Time
  19 import qualified Data.Time.Clock     as Time
  20 import qualified Data.Time.LocalTime as Time
  21 import           Data.Typeable ()
  22 import           Safe (headDef, lastDef)
  23 import qualified Text.Parsec as P
  24 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  25 import           Text.Printf
  26
  27 import qualified Hcompta.Model as Model
  28 import qualified Hcompta.Model.Account as Account
  29 import           Hcompta.Model.Account (Account)
  30 import qualified Hcompta.Model.Amount as Amount
  31 import           Hcompta.Model.Amount (Amount, Conversion, Style, Unit)
  32 import qualified Hcompta.Model.Amount.Conversion as Conversion
  33 import qualified Hcompta.Model.Amount.Quantity as Quantity
  34 import qualified Hcompta.Model.Amount.Style as Style
  35 import qualified Hcompta.Model.Amount.Unit as Unit
  36 import qualified Hcompta.Model.Date as Date
  37 import           Hcompta.Format.Ledger.Journal as Journal
  38 import qualified Hcompta.Lib.Regex as Regex
  39 import           Hcompta.Lib.Regex (Regex, (=~))
  40
  41 data Context
  42  =   Context
  43  { account_prefix :: !Account
  44  , context_aliases_exact :: !(Data.Map.Map Account Account)
  45  , context_aliases_joker :: ![(Account.Joker, Account)]
  46  , context_aliases_regex :: ![(Regex, Account)]
  47  , unit_and_style :: !(Maybe (Amount.Unit, Amount.Style))
  48  , journal :: !Journal
  49  , year :: !Date.Year
  50  } deriving (Show)
  51
  52 nil :: Context
  53 nil =
  54         Context
  55          { account_prefix = []
  56                 , context_aliases_exact = Data.Map.empty
  57                 , context_aliases_joker = []
  58                 , context_aliases_regex = []
  59          , unit_and_style = Nothing
  60          , journal = Journal.nil
  61          , year = (\(year, _ , _) -> year) $
  62                 Time.toGregorian $ Time.utctDay $
  63                 Journal.last_read_time Journal.nil
  64          }
  65
  66 -- * Utilities
  67
  68 -- ** Combinators
  69
  70 -- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
  71 choice_try :: Stream s m t => [ParsecT s st m a] -> ParsecT s st m a
  72 choice_try = P.choice . Data.List.map P.try
  73
  74 -- ** Numbers
  75
  76 -- | Return the 'Integer' obtained by multiplying the given digits
  77 --   with the power of the given base respective to their rank.
  78 integer_of_digits
  79  :: Integer -- ^ Base.
  80  -> [Char]  -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
  81  -> Integer
  82 integer_of_digits base =
  83         Data.List.foldl (\x d ->
  84                 base*x + toInteger (Data.Char.digitToInt d)) 0
  85
  86 decimal :: Stream [Char] m Char => ParsecT [Char] st m Integer
  87 decimal = integer 10 P.digit
  88 hexadecimal :: Stream [Char] m Char => ParsecT [Char] st m Integer
  89 hexadecimal = P.oneOf "xX" >> integer 16 P.hexDigit
  90 octal :: Stream [Char] m Char => ParsecT [Char] st m Integer
  91 octal = P.oneOf "oO" >> integer 8 P.octDigit
  92
  93 -- | Parse an 'Integer'.
  94 integer :: Stream [Char] m Char
  95        => Integer -> ParsecT [Char] st m Char
  96        -> ParsecT [Char] st m Integer
  97 integer base digit = do
  98         digits <- P.many1 digit
  99         let n = integer_of_digits base digits
 100         seq n (return n)
 101
 102 -- | Parse either '-' into 'negate', or '+' or '' into 'id'.
 103 sign :: (Stream [Char] m Char, Num i) => ParsecT [Char] st m (i -> i)
 104 sign =
 105         (P.char '-' >> return negate) <|>
 106         (P.char '+' >> return id) <|>
 107         return id
 108
 109 -- ** Whites
 110
 111 -- | Return 'True' if and only if the given 'Char' is an horizontal space.
 112 is_space_horizontal :: Char -> Bool
 113 is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c
 114
 115 space :: Stream [Char] m Char => ParsecT [Char] st m Char
 116 space = P.satisfy is_space_horizontal
 117
 118 -- * Parsing 'Account'.
 119
 120 -- | Parse an 'Account'.
 121 account :: Stream [Char] m Char => ParsecT [Char] st m Account
 122 account = do
 123         P.notFollowedBy $ P.satisfy is_space_horizontal
 124         P.sepBy1 account_name account_name_separator
 125
 126 -- | Parse an Account.'Account.Name'.
 127 account_name :: Stream [Char] m Char => ParsecT [Char] st m Account.Name
 128 account_name = do
 129         P.many1 $ do
 130                 P.satisfy is_space_horizontal
 131                         <* (P.lookAhead $ P.satisfy (not . Data.Char.isSpace))
 132                 <|> (P.notFollowedBy account_name_separator >> P.anyChar)
 133
 134 -- | Parse the Account.'Account.Name' separator: ':'.
 135 account_name_separator :: Stream [Char] m Char => ParsecT [Char] st m Char
 136 account_name_separator = P.char ':'
 137
 138 -- | Parse an Account.'Account.Joker_Name'.
 139 account_joker_name :: Stream [Char] m Char => ParsecT [Char] st m Account.Joker_Name
 140 account_joker_name = do
 141         n <- P.option Nothing $ (Just <$> account_name)
 142         case n of
 143          Nothing -> account_name_separator >> (return $ Account.Joker_Any)
 144          Just n -> return $ Account.Joker_Name n
 145
 146 -- | Parse an Account.'Account.Joker'.
 147 account_joker :: Stream [Char] m Char => ParsecT [Char] st m Account.Joker
 148 account_joker = do
 149         P.notFollowedBy $ P.satisfy is_space_horizontal
 150         P.sepBy1 account_joker_name account_name_separator
 151
 152 -- | Parse a 'Regex'.
 153 account_regex :: Stream [Char] m Char => ParsecT [Char] st m Regex
 154 account_regex = do
 155         re <- P.many1 $ P.satisfy (not . is_space_horizontal)
 156         Regex.of_StringM re
 157
 158 -- | Parse an Account.'Account.Filter'.
 159 account_pattern :: Stream [Char] m Char => ParsecT [Char] st m Account.Pattern
 160 account_pattern = do
 161         choice_try
 162          [ Account.Pattern_Exact <$> (P.char '=' >> account)
 163          , Account.Pattern_Joker <$> (P.char '*' >> account_joker)
 164          , Account.Pattern_Regex <$> (P.option '~' (P.char '~') >> account_regex)
 165          ]
 166
 167 -- * Parsing 'Amount'.
 168
 169 -- | Parse an 'Amount'.
 170 amount :: Stream [Char] m Char => ParsecT [Char] st m Amount
 171 amount = do
 172         left_signing <- sign
 173         left_unit <-
 174                 P.option Nothing $ do
 175                         u <- unit
 176                         s <- P.many $ P.satisfy is_space_horizontal
 177                         return $ Just $ (u, not $ null s)
 178         (quantity_, style) <- do
 179                 signing <- sign
 180                 Quantity
 181                  { integral
 182                  , fractional
 183                  , fractioning
 184                  , grouping_integral
 185                  , grouping_fractional
 186                  } <-
 187                         choice_try
 188                          [ quantity '_' ',' '_' <* (P.notFollowedBy $ P.oneOf ",._")
 189                          , quantity '_' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
 190                          , quantity ',' '.' '_' <* (P.notFollowedBy $ P.oneOf ",._")
 191                          , quantity '.' ',' '_' <* (P.notFollowedBy $ P.oneOf ",._")
 192                          ] <?> "quantity"
 193                 let int = Data.List.concat integral
 194                 let frac_flat = Data.List.concat fractional
 195                 let frac = reverse $ Data.List.dropWhile (== '0') $ reverse $ frac_flat
 196                 let place = length frac
 197                 guard (place <= 255)
 198                 let mantissa = integer_of_digits 10 $ int ++ frac
 199                 return $
 200                  ( Data.Decimal.Decimal
 201                          (fromIntegral place)
 202                          (signing mantissa)
 203                  , Style.nil
 204                          { Style.fractioning = fractioning
 205                          , Style.grouping_integral = grouping_integral
 206                          , Style.grouping_fractional = grouping_fractional
 207                          , Style.precision = fromIntegral $ length frac_flat
 208                          }
 209                  )
 210         (unit_, side, spaced) <-
 211                 case left_unit of
 212                  Just (u, s) ->
 213                         return (u, Just Style.Side_Left, Just s)
 214                  Nothing ->
 215                         P.option (Unit.nil, Nothing, Nothing) $ do
 216                                 s <- P.many $ P.satisfy is_space_horizontal
 217                                 u <- unit
 218                                 return $ (u, Just Style.Side_Right, Just $ not $ null s)
 219         return $
 220                 Amount.Amount
 221                  { Amount.conversion = Conversion.nil -- TODO
 222                  , Amount.quantity = left_signing $ quantity_
 223                  , Amount.style = style
 224                          { Style.unit_side = side
 225                          , Style.unit_spaced = spaced
 226                          }
 227                  , Amount.unit = unit_
 228                  }
 229
 230 data Quantity
 231  =   Quantity
 232  { integral :: [String]
 233  , fractional :: [String]
 234  , fractioning :: Maybe Style.Fractioning
 235  , grouping_integral :: Maybe Style.Grouping
 236  , grouping_fractional :: Maybe Style.Grouping
 237  }
 238
 239 -- | Parse a 'Quantity'.
 240 quantity
 241  :: Stream [Char] m Char
 242  => Char -- ^ Integral grouping separator.
 243  -> Char -- ^ Fractioning separator.
 244  -> Char -- ^ Fractional grouping separator.
 245  -> ParsecT [Char] st m Quantity
 246 quantity int_group_sep frac_sep frac_group_sep = do
 247         (integral, grouping_integral) <- do
 248                 h <- P.many P.digit
 249                 case h of
 250                  [] -> return ([], Nothing)
 251                  _ -> do
 252                         t <- P.many $ P.char int_group_sep >> P.many1 P.digit
 253                         let digits = h:t
 254                         return (digits, grouping_of_digits int_group_sep digits)
 255         (fractional, fractioning, grouping_fractional) <-
 256                 (case integral of
 257                  [] -> id
 258                  _ -> P.option ([], Nothing, Nothing)) $ do
 259                         fractioning <- P.char frac_sep
 260                         h <- P.many P.digit
 261                         t <- P.many $ P.char frac_group_sep >> P.many1 P.digit
 262                         let digits = h:t
 263                         return (digits, Just fractioning
 264                          , grouping_of_digits frac_group_sep $ reverse digits)
 265         return $
 266                 Quantity
 267                  { integral
 268                  , fractional
 269                  , fractioning
 270                  , grouping_integral
 271                  , grouping_fractional
 272                  }
 273         where
 274                 grouping_of_digits :: Char -> [String] -> Maybe Style.Grouping
 275                 grouping_of_digits group_sep digits =
 276                         case digits of
 277                          [] -> Nothing
 278                          [_] -> Nothing
 279                          _ -> Just $
 280                                 Style.Grouping group_sep $
 281                                 canonicalize_grouping $
 282                                 map length $ digits
 283                 canonicalize_grouping :: [Int] -> [Int]
 284                 canonicalize_grouping groups =
 285                         Data.List.foldl -- NOTE: remove duplicates at begining and reverse.
 286                          (\acc l0 -> case acc of
 287                                  l1:_ -> if l0 == l1 then acc else l0:acc
 288                                  _ -> l0:acc) [] $
 289                         case groups of -- NOTE: keep only longer at begining.
 290                          l0:l1:t -> if l0 > l1 then groups else l1:t
 291                          _ -> groups
 292
 293 -- | Parse an 'Unit'.
 294 unit :: Stream [Char] m Char => ParsecT [Char] st m Unit
 295 unit =
 296         (quoted <|> unquoted) <?> "unit"
 297         where
 298                 unquoted :: Stream [Char] m Char => ParsecT [Char] st m Unit
 299                 unquoted =
 300                         P.many1 $
 301                                 P.satisfy $ \c ->
 302                                         case Data.Char.generalCategory c of
 303                                          Data.Char.CurrencySymbol  -> True
 304                                          Data.Char.LowercaseLetter -> True
 305                                          Data.Char.ModifierLetter  -> True
 306                                          Data.Char.OtherLetter     -> True
 307                                          Data.Char.TitlecaseLetter -> True
 308                                          Data.Char.UppercaseLetter -> True
 309                                          _ -> False
 310                 quoted :: Stream [Char] m Char => ParsecT [Char] st m Unit
 311                 quoted =
 312                         P.between (P.char '"') (P.char '"') $
 313                                 P.many1 $
 314                                         P.noneOf ";\n\""
 315
 316 -- * Directives
 317 -- ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate
 318
 319 directive_alias :: Stream [Char] m Char => ParsecT [Char] Context m ()
 320 directive_alias = do
 321         P.string "alias"
 322         P.many1 $ P.satisfy is_space_horizontal
 323         pattern <- account_pattern
 324         P.many $ P.satisfy is_space_horizontal
 325         P.char '='
 326         P.many $ P.satisfy is_space_horizontal
 327         repl <- account
 328         P.many $ P.satisfy is_space_horizontal
 329         case pattern of
 330          Account.Pattern_Exact acct -> P.modifyState $ \ctx -> ctx{context_aliases_exact=
 331                 Data.Map.insert acct repl $ context_aliases_exact ctx}
 332          Account.Pattern_Joker jokr -> P.modifyState $ \ctx -> ctx{context_aliases_joker=
 333                 (jokr, repl):context_aliases_joker ctx}
 334          Account.Pattern_Regex regx -> P.modifyState $ \ctx -> ctx{context_aliases_regex=
 335                 (regx, repl):context_aliases_regex ctx}
 336         return ()
 337
 338 -- | Parse the year, month and day separator: '/' or '-'.
 339 date_separator :: Stream [Char] m Char => ParsecT [Char] st m Char
 340 date_separator = P.satisfy (\c -> c == '/' || c == '-')
 341
 342 -- | Parse the hour, minute and second separator: ':'.
 343 hour_separator :: Stream [Char] m Char => ParsecT [Char] st m Char
 344 hour_separator = P.char ':'
 345
 346 -- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed.
 347 -- The year may be omitted if a default year has already been set.
 348 date :: Stream [Char] m t => ParsecT [Char] Context m Date
 349 date = do
 350         n0 <- P.many1 P.digit
 351         date_sep <- date_separator
 352         n1 <- P.count 2 P.digit <|> P.count 1 P.digit
 353         n2 <- P.option Nothing $ (P.char date_sep >> (Just <$> (P.count 2 P.digit <|> P.count 1 P.digit)))
 354         (y, m, d) <-
 355                 case n2 of
 356                  Nothing -> do
 357                         y <- liftM context_year getState
 358                         return (y, n0, n1)
 359                  Just d -> return (n0, n1, d)
 360         year  <- integer_of_digits 10 y
 361         month <- integer_of_digits 10 m
 362         day   <- integer_of_digits 10 d
 363         guard $ month >= 1 && month <= 12
 364         guard $ day   >= 1 && day   <= 31
 365
 366         P.many1 $ P.satisfy is_space_horizontal
 367
 368         h <- P.count 2 P.digit <|> P.count 1 P.digit
 369         hour_sep <- hour_separator
 370         mi <- P.count 2 P.digit <|> P.count 1 P.digit
 371         s <- P.option Nothing $ (P.char hour_sep >> (Just <$> (P.count 2 P.digit <|> P.count 1 P.digit)))
 372         year  <- integer_of_digits 10 y
 373         month <- integer_of_digits 10 m
 374         day   <- integer_of_digits 10 d
 375         guard $ hour  >= 1 && month <= 12
 376         guard $ month >= 1 && month <= 12
 377         guard $ day   >= 1 && day   <= 31
 378
 379         -- XXX reported error position is not too good
 380         -- pos <- getPosition
 381         datestr <- many1 $ choice_try [digit, datesepchar]
 382         let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
 383         when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
 384         let dateparts = wordsBy (`elem` datesepchars) datestr
 385         currentyear <- getYear
 386         [y, m, d] <-
 387                 case (dateparts,currentyear) of
 388                  ([m,d],Just y)  -> return [show y,m,d]
 389                  ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"
 390                  ([y,m,d],_)     -> return [y,m,d]
 391                  _               -> fail $ "bad date: " ++ datestr
 392         let maybedate = fromGregorianValid (read y) (read m) (read d)
 393         case maybedate of
 394          Nothing   -> fail $ "bad date: " ++ datestr
 395          Just date -> return date
 396         <?> "full or partial date"
 397
 398 -- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format.
 399 -- Any timezone will be ignored; the time is treated as local time.
 400 -- Fewer digits are allowed, except in the timezone.
 401 -- The year may be omitted if a default year has already been set.
 402 parseDateTime :: Stream [Char] m Char => ParsecT [Char] Context m LocalTime
 403 parseDateTime = do
 404         day <- parseDate
 405         many1 spacenonewline
 406         h <- many1 digit
 407         let h' = read h
 408         guard $ h' >= 0 && h' <= 23
 409         char ':'
 410         m <- many1 digit
 411         let m' = read m
 412         guard $ m' >= 0 && m' <= 59
 413         s <- optionMaybe $ char ':' >> many1 digit
 414         let s' = case s of Just sstr -> read sstr
 415                            Nothing   -> 0
 416         guard $ s' >= 0 && s' <= 59
 417         {- tz <- -}
 418         optionMaybe $ do
 419                 plusminus <- oneOf "-+"
 420                 d1 <- digit
 421                 d2 <- digit
 422                 d3 <- digit
 423                 d4 <- digit
 424                 return $ plusminus:d1:d2:d3:d4:""
 425         -- ltz <- liftIO $ getCurrentTimeZone
 426         -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
 427         -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
 428         return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
 429
 430 -- | Parse a 'Posting'.
 431 posting :: Stream [Char] m Char => ParsecT [Char] Context m Posting
 432 posting = do
 433         _ <- P.many1 $ P.satisfy is_space_horizontal
 434         -- status <- parseStatus -- TODO
 435         _ <- P.many $ P.satisfy is_space_horizontal
 436         account <- modifiedaccountname
 437         let (ptype, account') = (accountNamePostingType account, unbracket account)
 438         amount <- spaceandamountormissing
 439         massertion <- partialbalanceassertion
 440         _ <- fixedlotprice
 441         many spacenonewline
 442         ctx <- getState
 443         comment <- try followingcommentp <|> (newline >> return "")
 444         let tags = tagsInComment comment
 445         coa <- getCoA
 446         date <-
 447                 case dateValueFromTags tags of
 448                  Nothing -> return Nothing
 449                  Just v ->
 450                         case runParser (parseDate <* eof) ctx "" v of
 451                          Right d -> return $ Just d
 452                          Left err -> parserFail $ show err
 453         date2 <-
 454                 case date2ValueFromTags tags of
 455                  Nothing -> return Nothing
 456                  Just v ->
 457                         case runParser (parseDate <* eof) ctx "" v of
 458                          Right d -> return $ Just d
 459                          Left err -> parserFail $ show err
 460         return posting
 461          { Posting.date=date
 462          , Posting.date2=date2
 463          , Posting.status=status
 464          , Posting.account=account'
 465          , Posting.amount=amount
 466          , Posting.comment=comment
 467          , Posting.type=ptype
 468          , Posting.tags=tags
 469          , Posting.coa=pcoa
 470          , Posting.balanceassertion=massertion
 471          }
 472
 473 {-
 474 -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
 475 account_with_context :: Stream [Char] m Char => ParsecT [Char] Context m Account
 476 account_with_context = do
 477         acct <- account
 478         prefix <- liftM context_account_prefix P.getState
 479         aliases <- getAccountAliases
 480         return $ accountNameApplyAliases aliases $ Account.(++) prefix acct
 481
 482
 483 -}
 484 {-
 485
 486 account :: Stream [Char] m Char => ParsecT [Char] st m Account
 487 account = do
 488         P.notFollowedBy $ P.satisfy is_space
 489                 single_space = try (P.satisfy is_space <* P.notFollowedBy $ P.satisfy is_space)
 490         a <- P.many1 (not_spaces <|> single_space)
 491         let a' = striptrailingspace a
 492         when (accountNameFromComponents (accountNameComponents a') /= a')
 493              (fail $ "account name seems ill-formed: "++a')
 494         return a'
 495         where
 496                 single_space = try (P.satisfy is_space <* P.notFollowedBy $ P.satisfy is_space)
 497                 striptrailingspace s = if last s == ' ' then init s else s
 498
 499 parsePosting :: Stream [Char] m Char => ParsecT [Char] Context m Posting
 500 parsePosting = do
 501         many1 spacenonewline
 502         status <- parseStatus
 503         many spacenonewline
 504         account <- modifiedaccountname
 505         let (ptype, account') = (accountNamePostingType account, unbracket account)
 506         amount <- spaceandamountormissing
 507         massertion <- partialbalanceassertion
 508         _ <- fixedlotprice
 509         many spacenonewline
 510         ctx <- getState
 511         comment <- try followingcommentp <|> (newline >> return "")
 512         let tags = tagsInComment comment
 513         coa <- getCoA
 514         pcoa <-
 515                 if isZeroMixedAmount amount
 516                 then do
 517                         let coa_ = coaAdd coa (accountNameComponents account) tags
 518                         setCoA coa_
 519                         return coa_
 520                 else return coa
 521         date <-
 522                 case dateValueFromTags tags of
 523                  Nothing -> return Nothing
 524                  Just v ->
 525                         case runParser (parseDate <* eof) ctx "" v of
 526                          Right d -> return $ Just d
 527                          Left err -> parserFail $ show err
 528         date2 <-
 529                 case date2ValueFromTags tags of
 530                  Nothing -> return Nothing
 531                  Just v ->
 532                         case runParser (parseDate <* eof) ctx "" v of
 533                          Right d -> return $ Just d
 534                          Left err -> parserFail $ show err
 535         return posting
 536          { Posting.date=date
 537          , Posting.date2=date2
 538          , Posting.status=status
 539          , Posting.account=account'
 540          , Posting.amount=amount
 541          , Posting.comment=comment
 542          , Posting.type=ptype
 543          , Posting.tags=tags
 544          , Posting.coa=pcoa
 545          , Posting.balanceassertion=massertion
 546          }
 547 -}
 548
 549 {-
 550 reader :: Reader
 551 reader = Reader format detect parse
 552
 553 format :: String
 554 format = "ledger"
 555
 556 detect :: FilePath -> String -> Bool
 557 detect file s
 558         | file /= "-"  = takeExtension file `elem` ['.':format, ".j"]  -- from a file: yes if the extension is .journal or .j
 559         -- from stdin: yes if we can see something that looks like a journal entry (digits in column 0 with the next line indented)
 560         | otherwise = regexMatches "^[0-9]+.*\n[ \t]+" s
 561
 562 parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal
 563 parse _ = parseJournal journal
 564
 565 parseJournal
 566  :: ParsecT [Char] Context (ErrorT String IO) Context
 567  -> Bool -> FilePath -> String -> ErrorT String IO Journal
 568 parseJournal parser filePath fileData = do
 569         currentUTC <- liftIO Time.getCurrentTime
 570         currentTimeZone <- liftIO Time.getCurrentTimeZone
 571         let currentLocalTime = Time.utcToLocalTime currentTimeZone currentUTC
 572         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
 573         parserResult <- runParserT parser
 574          contextNull{context_year=Just currentLocalYear}
 575          filePath fileData
 576         case parserResult of
 577          Left error -> throwError $ show error
 578          Right context -> do
 579                 let journal = context_journal context
 580                 journalBalanceTransactions $
 581                 journal
 582                  { journal_unit_styles=
 583                  , journal_file=filePath
 584                  , journal_includes=reverse $ journal_includes journal
 585                  -- , journal_historical_prices=reverse $ journal_historical_prices journal
 586                  , journal_last_read_time=currentUTC
 587                  , journal_transactions=reverse $ journal_transactions journal
 588                  -- , journal_transaction_modifiers=reverse $ journal_transaction_modifiers journal
 589                  -- , journal_transaction_periodics=reverse $ journal_transaction_periodics journal
 590                  }
 591
 592 -- | Fill in any missing amounts and check that all journal transactions
 593 -- balance, or return an error message. This is done after parsing all
 594 -- amounts and working out the canonical commodities, since balancing
 595 -- depends on display precision. Reports only the first error encountered.
 596 journalBalanceTransactions :: Journal -> Either String Journal
 597 journalBalanceTransactions journal =
 598         let transactions = journal_transactions journal
 599         let unit_and_style = journal_unit_styles journal
 600         case sequence $ map balance transactions of
 601          Right ts' -> Right journal{journal_transactions=map txnTieKnot ts'}
 602          Left e    -> Left e
 603         where balance = balanceTransaction (Just unit_and_style)
 604
 605 -- | Convert all the journal's posting amounts (not price amounts) to
 606 -- their canonical display settings. Ie, all amounts in a given
 607 -- unit will use (a) the display settings of the first, and (b)
 608 -- the greatest precision, of the posting amounts in that unit.
 609 journalCanonicaliseAmounts :: Journal -> Journal
 610 journalCanonicaliseAmounts j@Journal{journal_transactions=ts} =
 611         j''
 612         where
 613                 j'' = j'{journal_transactions=map fixtransaction ts}
 614                 j' = j{context_unit_and_style = canonicalStyles $ dbgAt 8 "journalAmounts" $ journalAmounts j}
 615                 fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}
 616                 fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}
 617                 fixmixedamount (Mixed as) = Mixed $ map fixamount as
 618                 fixamount a@Amount{aunit=c} = a{astyle=journalCommodityStyle j' c}
 619
 620 -- | Given a list of amounts in parse order, build a map from commodities
 621 -- to canonical display styles for amounts in that unit.
 622 canonicalStyles :: [Amount] -> M.Map Amount.Unit Amount.Style
 623 canonicalStyles amts =
 624         M.fromList commstyles
 625         where
 626                 samecomm = \a1 a2 -> aunit a1 == aunit a2
 627                 commamts = [(aunit $ head as, as) | as <- groupBy samecomm $ sortBy (comparing aunit) amts]
 628                 commstyles = [(c, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts]
 629
 630 -- | Get all this journal's component amounts, roughly in the order parsed.
 631 journalAmounts :: Journal -> [Amount]
 632 journalAmounts =
 633         concatMap flatten . journalMixedAmounts
 634         where flatten (Mixed as) = as
 635
 636 amountStyleFromCommodity :: Context -> Amount.Unit -> Amount.Style
 637 amountStyleFromCommodity context unit =
 638         Data.Map.findWithDefault
 639          (context_unit_and_style context)
 640          unit $
 641         journal_unit_styles $
 642         context_journal context
 643
 644
 645
 646
 647 setYear :: Stream [Char] m Char => Integer -> ParsecT [Char] Context m ()
 648 setYear y = modifyState (\ctx -> ctx{context_year=Just y})
 649
 650 getYear :: Stream [Char] m Char => ParsecT s Context m (Maybe Integer)
 651 getYear = liftM context_year getState
 652
 653 setCoA :: Stream [Char] m Char => CoA -> ParsecT [Char] Context m ()
 654 setCoA coa = modifyState (\ctx -> ctx{ctxCoA=coa})
 655
 656 getCoA :: Stream [Char] m Char => ParsecT [Char] Context m CoA
 657 getCoA = liftM ctxCoA getState
 658
 659 setDefaultCommodityAndStyle :: Stream [Char] m Char => (Amount.Unit,Amount.Style) -> ParsecT [Char] Context m ()
 660 setDefaultCommodityAndStyle cs = modifyState (\ctx -> ctx{context_unit_and_style=Just cs})
 661
 662 getDefaultCommodityAndStyle :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe (Amount.Unit,Amount.Style))
 663 getDefaultCommodityAndStyle = context_unit_and_style `fmap` getState
 664
 665 pushParentAccount :: Stream [Char] m Char => String -> ParsecT [Char] Context m ()
 666 pushParentAccount parent = modifyState addParentAccount
 667     where addParentAccount ctx0 = ctx0 { context_account_prefix = parent : context_account_prefix ctx0 }
 668
 669 popParentAccount :: Stream [Char] m Char => ParsecT [Char] Context m ()
 670 popParentAccount = do
 671         ctx0 <- getState
 672         case context_account_prefix ctx0 of
 673          [] -> unexpected "End of account block with no beginning"
 674          (_:rest) -> setState $ ctx0 { context_account_prefix = rest }
 675
 676 getParentAccount :: Stream [Char] m Char => ParsecT [Char] Context m String
 677 getParentAccount = liftM (concatAccountNames . reverse . context_account_prefix) getState
 678
 679 addAccountAlias :: Stream [Char] m Char => AccountAlias -> ParsecT [Char] Context m ()
 680 addAccountAlias a = modifyState (\(ctx@Ctx{..}) -> ctx{context_aliases=a:context_aliases})
 681
 682 getAccountAliases :: Stream [Char] m Char => ParsecT [Char] Context m [AccountAlias]
 683 getAccountAliases = liftM context_aliases getState
 684
 685 clearAccountAliases :: Stream [Char] m Char => ParsecT [Char] Context m ()
 686 clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{context_aliases=[]})
 687
 688 -- parsers
 689
 690 parseJournal :: ParsecT [Char] Context (ErrorT String IO) (JournalUpdate, Context)
 691 parseJournal = do
 692         journalUpdates <- many journalItem
 693         eof
 694         finalContext <- getState
 695         return $ (combineJournalUpdates journalUpdates, finalContext)
 696                 where
 697                         -- As all journal line types can be distinguished by the first
 698                         -- character, excepting transactions versus empty (blank or
 699                         -- comment-only) lines, can use choice w/o try
 700                         journalItem =
 701                                 choice
 702                                  [ directive
 703                                  , liftM (return . addTransaction) parseTransaction
 704                                  , liftM (return . addModifierTransaction) parseTransactionModifier
 705                                  , liftM (return . addPeriodicTransaction) periodictransaction
 706                                  , liftM (return . addHistoricalPrice) historicalpricedirective
 707                                  , emptyorcommentlinep >> return (return id)
 708                                  , multilinecommentp >> return (return id)
 709                                  ] <?> "journal transaction or directive"
 710
 711 parseDirective :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 712 parseDirective = do
 713         optional $ char '!'
 714         choice'
 715          [ parseDirectiveInclude
 716          , parseDirectiveAlias
 717          , parseDirectiveEndAlias
 718          , parseDirectiveAccount
 719          , parseDirectiveEnd
 720          , parseDirectiveTag
 721          , parseDirectiveEndTag
 722          , parseDirectiveYear
 723          , parseDirectiveCommodity
 724          , parseDirectiveCommodityConversion
 725          , parseDirectiveIgnoredPriceCommodity
 726          ]
 727         <?> "directive"
 728
 729 parseDirectiveInclude :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 730 parseDirectiveInclude = do
 731         string "include"
 732         many1 spacenonewline
 733         filename <- restofline
 734         outerState <- getState
 735         outerPos <- getPosition
 736         let curdir = takeDirectory (sourceName outerPos)
 737         let (u::ErrorT String IO (Journal -> Journal, Context)) = do
 738                 filepath <- expandPath curdir filename
 739                 txt <- readFileOrError outerPos filepath
 740                 let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
 741                 r <- runParserT parseJournal outerState filepath txt
 742                 case r of
 743                  Right (ju, ctx) -> do
 744                         u <- combineJournalUpdates [ return $ journalAddFile (filepath,txt)
 745                                                    , ju
 746                                                    ] `catchError` (throwError . (inIncluded ++))
 747                         return (u, ctx)
 748                  Left err -> throwError $ inIncluded ++ show err
 749                 where readFileOrError pos fp =
 750                         ErrorT $ liftM Right (readFile' fp) `Exn.catch`
 751                           \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::Exn.IOException))
 752         r <- liftIO $ runErrorT u
 753         case r of
 754          Left err -> return $ throwError err
 755          Right (ju, ctx) -> do
 756                 setCoA (ctxCoA ctx)
 757                 return $ ErrorT $ return $ Right ju
 758
 759 journalAddFile :: (FilePath,String) -> Journal -> Journal
 760 journalAddFile f j@Journal{journal_files=fs} = j{journal_files=fs++[f]}
 761  -- NOTE: first encountered file to left, to avoid a reverse
 762
 763 parseDirectiveAccount :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 764 parseDirectiveAccount = do
 765   string "account"
 766   many1 spacenonewline
 767   parent <- parseAccountName
 768   newline
 769   pushParentAccount parent
 770   -- return $ return id
 771   return $ ErrorT $ return $ Right id
 772
 773 parseDirectiveEnd :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 774 parseDirectiveEnd = do
 775   string "end"
 776   popParentAccount
 777   -- return (return id)
 778   return $ ErrorT $ return $ Right id
 779
 780 parseDirectiveAlias :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 781 parseDirectiveAlias = do
 782   string "alias"
 783   many1 spacenonewline
 784   orig <- many1 $ noneOf "="
 785   char '='
 786   alias <- restofline
 787   addAccountAlias (accountNameWithoutPostingType $ strip orig
 788                   ,accountNameWithoutPostingType $ strip alias)
 789   return $ return id
 790
 791 parseDirectiveEndAlias :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 792 parseDirectiveEndAlias = do
 793   string "end aliases"
 794   clearAccountAliases
 795   return (return id)
 796
 797 parseDirectiveTag :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 798 parseDirectiveTag = do
 799   string "tag" <?> "tag directive"
 800   many1 spacenonewline
 801   _ <- many1 nonspace
 802   restofline
 803   return $ return id
 804
 805 parseDirectiveEndTag :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 806 parseDirectiveEndTag = do
 807         (string "end tag" <|> string "pop") <?> "end tag or pop directive"
 808         restofline
 809         return $ return id
 810
 811 parseDirectiveYear :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 812 parseDirectiveYear = do
 813         char 'Y' <?> "default year"
 814         many spacenonewline
 815         y <- many1 digit
 816         let y' = read y
 817         failIfInvalidYear y
 818         setYear y'
 819         return $ return id
 820
 821 parseDirectiveCommodity :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 822 parseDirectiveCommodity = do
 823         char 'D' <?> "default unit"
 824         many1 spacenonewline
 825         Amount{..} <- getDefaultCommodityAndStyle >>= parseAmount
 826         setDefaultCommodityAndStyle (aunit, astyle)
 827         restofline
 828         return $ return id
 829
 830 parseDirectiveHistoricalPrice :: ParsecT [Char] Context (ErrorT String IO) HistoricalPrice
 831 parseDirectiveHistoricalPrice = do
 832         char 'P' <?> "historical price"
 833         many spacenonewline
 834         date <- try (do {LocalTime d _ <- parseDateTime; return d}) <|> parseDate -- a time is ignored
 835         many1 spacenonewline
 836         symbol <- parseCommodity
 837         many spacenonewline
 838         price <- getDefaultCommodityAndStyle >>= parseAmount
 839         restofline
 840         return $ HistoricalPrice date symbol price
 841
 842 parseDirectiveIgnoredPriceCommodity :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 843 parseDirectiveIgnoredPriceCommodity = do
 844         char 'N' <?> "ignored-price unit"
 845         many1 spacenonewline
 846         parseCommodity
 847         restofline
 848         return $ return id
 849
 850 parseDirectiveCommodityConversion :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 851 parseDirectiveCommodityConversion = do
 852         char 'C' <?> "unit conversion"
 853         many1 spacenonewline
 854         default_cs <- getDefaultCommodityAndStyle
 855         parseAmount default_cs
 856         many spacenonewline
 857         char '='
 858         many spacenonewline
 859         parseAmount default_cs
 860         restofline
 861         return $ return id
 862
 863 parseTransactionModifier :: ParsecT [Char] Context (ErrorT String IO) ModifierTransaction
 864 parseTransactionModifier = do
 865         char '=' <?> "modifier transaction"
 866         many spacenonewline
 867         valueexpr <- restofline
 868         parsePostings <- parsePostings
 869         return $ ModifierTransaction valueexpr parsePostings
 870
 871 parseTransactionPeriodic :: ParsecT [Char] Context (ErrorT String IO) PeriodicTransaction
 872 parseTransactionPeriodic = do
 873         char '~' <?> "periodic transaction"
 874         many spacenonewline
 875         periodexpr <- restofline
 876         parsePostings <- parsePostings
 877         return $ PeriodicTransaction periodexpr parsePostings
 878
 879 -- | Parse a (possibly unbalanced) transaction.
 880 parseTransaction :: ParsecT [Char] Context (ErrorT String IO) Transaction
 881 parseTransaction = do
 882         -- ptrace "transaction"
 883         sourcepos <- getPosition
 884         date <- parseDate <?> "transaction"
 885         edate <- optionMaybe (parseDate2 date) <?> "secondary date"
 886         lookAhead (spacenonewline <|> newline) <?> "whitespace or newline"
 887         status <- parseStatus <?> "cleared flag"
 888         code <- parseCode <?> "transaction code"
 889         description <- descriptionp >>= return . strip
 890         comment <- try followingcommentp <|> (newline >> return "")
 891         let tags = tagsInComment comment
 892         parsePostings <- parsePostings
 893         return $ txnTieKnot $ Transaction sourcepos date edate status code description comment tags parsePostings ""
 894
 895 descriptionp = many (noneOf ";\n")
 896
 897 -- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year
 898 -- may be omitted if a default year has already been set.
 899 parseDate :: Stream [Char] m t => ParsecT [Char] Context m Day
 900 parseDate = do
 901         -- hacky: try to ensure precise errors for invalid dates
 902         -- XXX reported error position is not too good
 903         -- pos <- getPosition
 904         datestr <- many1 $ choice' [digit, datesepchar]
 905         let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
 906         when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
 907         let dateparts = wordsBy (`elem` datesepchars) datestr
 908         currentyear <- getYear
 909         [y, m, d] <-
 910                 case (dateparts,currentyear) of
 911                  ([m,d],Just y)  -> return [show y,m,d]
 912                  ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"
 913                  ([y,m,d],_)     -> return [y,m,d]
 914                  _               -> fail $ "bad date: " ++ datestr
 915         let maybedate = fromGregorianValid (read y) (read m) (read d)
 916         case maybedate of
 917          Nothing   -> fail $ "bad date: " ++ datestr
 918          Just date -> return date
 919         <?> "full or partial date"
 920
 921 -- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format.  Any
 922 -- timezone will be ignored; the time is treated as local time.  Fewer
 923 -- digits are allowed, except in the timezone. The year may be omitted if
 924 -- a default year has already been set.
 925 parseDateTime :: Stream [Char] m Char => ParsecT [Char] Context m LocalTime
 926 parseDateTime = do
 927         day <- parseDate
 928         many1 spacenonewline
 929         h <- many1 digit
 930         let h' = read h
 931         guard $ h' >= 0 && h' <= 23
 932         char ':'
 933         m <- many1 digit
 934         let m' = read m
 935         guard $ m' >= 0 && m' <= 59
 936         s <- optionMaybe $ char ':' >> many1 digit
 937         let s' = case s of Just sstr -> read sstr
 938                            Nothing   -> 0
 939         guard $ s' >= 0 && s' <= 59
 940         {- tz <- -}
 941         optionMaybe $ do
 942                 plusminus <- oneOf "-+"
 943                 d1 <- digit
 944                 d2 <- digit
 945                 d3 <- digit
 946                 d4 <- digit
 947                 return $ plusminus:d1:d2:d3:d4:""
 948         -- ltz <- liftIO $ getCurrentTimeZone
 949         -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
 950         -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
 951         return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
 952
 953 parseDate2 :: Stream [Char] m Char => Day -> ParsecT [Char] Context m Day
 954 parseDate2 primarydate = do
 955         char '='
 956         -- kludgy way to use primary date for default year
 957         let withDefaultYear d p = do
 958                 y <- getYear
 959                 let (y',_,_) = toGregorian d in setYear y'
 960                 r <- p
 961                 when (isJust y) $ setYear $ fromJust y
 962                 return r
 963         edate <- withDefaultYear primarydate parseDate
 964         return edate
 965
 966 parseStatus :: Stream [Char] m Char => ParsecT [Char] Context m Bool
 967 parseStatus = try (do { many spacenonewline; (char '*' <|> char '!') <?> "status"; return True } ) <|> return False
 968
 969 parseCode :: Stream [Char] m Char => ParsecT [Char] Context m String
 970 parseCode = try (do { many1 spacenonewline; char '(' <?> "parseCode"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
 971
 972 -- Parse the following whitespace-beginning lines as parsePostings, posting tags, and/or comments.
 973 parsePostings :: Stream [Char] m Char => ParsecT [Char] Context m [Posting]
 974 parsePostings = many1 (try parsePosting) <?> "parsePostings"
 975
 976 parsePosting :: Stream [Char] m Char => ParsecT [Char] Context m Posting
 977 parsePosting = do
 978         many1 spacenonewline
 979         status <- parseStatus
 980         many spacenonewline
 981         account <- modifiedaccountname
 982         let (ptype, account') = (accountNamePostingType account, unbracket account)
 983         amount <- spaceandamountormissing
 984         massertion <- partialbalanceassertion
 985         _ <- fixedlotprice
 986         many spacenonewline
 987         ctx <- getState
 988         comment <- try followingcommentp <|> (newline >> return "")
 989         let tags = tagsInComment comment
 990         coa <- getCoA
 991         pcoa <-
 992                 if isZeroMixedAmount amount
 993                 then do
 994                         let coa_ = coaAdd coa (accountNameComponents account) tags
 995                         setCoA coa_
 996                         return coa_
 997                 else return coa
 998         date <-
 999                 case dateValueFromTags tags of
1000                  Nothing -> return Nothing
1001                  Just v ->
1002                         case runParser (parseDate <* eof) ctx "" v of
1003                          Right d -> return $ Just d
1004                          Left err -> parserFail $ show err
1005         date2 <-
1006                 case date2ValueFromTags tags of
1007                  Nothing -> return Nothing
1008                  Just v ->
1009                         case runParser (parseDate <* eof) ctx "" v of
1010                          Right d -> return $ Just d
1011                          Left err -> parserFail $ show err
1012         return posting
1013          { Posting.date=date
1014          , Posting.date2=date2
1015          , Posting.status=status
1016          , Posting.account=account'
1017          , Posting.amount=amount
1018          , Posting.comment=comment
1019          , Posting.type=ptype
1020          , Posting.tags=tags
1021          , Posting.coa=pcoa
1022          , Posting.balanceassertion=massertion
1023          }
1024
1025
1026 -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
1027 modifiedaccountname :: Stream [Char] m Char => ParsecT [Char] Context m AccountName
1028 modifiedaccountname = do
1029   a <- parseAccountName
1030   prefix <- getParentAccount
1031   let prefixed = prefix `joinAccountNames` a
1032   aliases <- getAccountAliases
1033   return $ accountNameApplyAliases aliases prefixed
1034
1035 -- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace
1036 --     <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"
1037
1038 -- | Parse whitespace then an amount, with an optional left or right
1039 -- currency symbol and optional price, or return the special
1040 -- "missing" marker amount.
1041 spaceandamountormissing :: Stream [Char] m Char => ParsecT [Char] Context m MixedAmount
1042 spaceandamountormissing = do
1043   default_cs <- getDefaultCommodityAndStyle
1044   try (do
1045         many1 spacenonewline
1046         (Mixed . (:[])) `fmap` parseAmount default_cs <|> return missingmixedamt
1047       ) <|> return missingmixedamt
1048
1049 partialbalanceassertion :: Stream [Char] m t => ParsecT [Char] Context m (Maybe MixedAmount)
1050 partialbalanceassertion = do
1051     default_cs <- getDefaultCommodityAndStyle
1052     try (do
1053           many spacenonewline
1054           char '='
1055           many spacenonewline
1056           a <- parseAmount default_cs -- XXX should restrict to a simple amount
1057           return $ Just $ Mixed [a])
1058          <|> return Nothing
1059
1060 -- balanceassertion :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe MixedAmount)
1061 -- balanceassertion =
1062 --     default_cs <- getDefaultCommodityAndStyle
1063 --     try (do
1064 --           many spacenonewline
1065 --           string "=="
1066 --           many spacenonewline
1067 --           a <- parseAmount default_cs -- XXX should restrict to a simple amount
1068 --           return $ Just $ Mixed [a])
1069 --          <|> return Nothing
1070
1071 -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
1072 fixedlotprice :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe Amount)
1073 fixedlotprice = do
1074     default_cs <- getDefaultCommodityAndStyle
1075     try (do
1076           many spacenonewline
1077           char '{'
1078           many spacenonewline
1079           char '='
1080           many spacenonewline
1081           a <- parseAmount default_cs -- XXX should restrict to a simple amount
1082           many spacenonewline
1083           char '}'
1084           return $ Just a)
1085          <|> return Nothing
1086
1087 -- comment parsers
1088
1089 multilinecommentp :: Stream [Char] m Char => ParsecT [Char] Context m ()
1090 multilinecommentp = do
1091   string "comment" >> newline
1092   go
1093   where
1094     go = try (string "end comment" >> newline >> return ())
1095          <|> (anyLine >> go)
1096     anyLine = anyChar `manyTill` newline
1097
1098 emptyorcommentlinep :: Stream [Char] m Char => ParsecT [Char] Context m ()
1099 emptyorcommentlinep = do
1100   many spacenonewline >> (parseComment <|> (many spacenonewline >> newline >> return ""))
1101   return ()
1102
1103 followingcommentp :: Stream [Char] m Char => ParsecT [Char] Context m String
1104 followingcommentp =
1105   -- ptrace "followingcommentp"
1106   do samelinecomment <- many spacenonewline >> (try semicoloncomment <|> (newline >> return ""))
1107      newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment))
1108      return $ unlines $ samelinecomment:newlinecomments
1109
1110 parseComment :: Stream [Char] m Char => ParsecT [Char] Context m String
1111 parseComment = commentStartingWith commentchars
1112
1113 commentchars :: [Char]
1114 commentchars = "#;*"
1115
1116 semicoloncomment :: Stream [Char] m Char => ParsecT [Char] Context m String
1117 semicoloncomment = commentStartingWith ";"
1118
1119 commentStartingWith :: Stream [Char] m Char => String -> ParsecT [Char] Context m String
1120 commentStartingWith cs = do
1121   -- ptrace "commentStartingWith"
1122   oneOf cs
1123   many spacenonewline
1124   l <- anyChar `manyTill` eolof
1125   optional newline
1126   return l
1127
1128 tagsInComment :: String -> [Tag]
1129 tagsInComment c = concatMap tagsInCommentLine $ lines c'
1130   where
1131     c' = ledgerDateSyntaxToTags c
1132
1133 tagsInCommentLine :: String -> [Tag]
1134 tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','
1135   where
1136     maybetag s = case runParser (parseTag <* eof) contextNull "" s of
1137                   Right t -> Just t
1138                   Left _ -> Nothing
1139
1140 parseTag = do
1141         -- ptrace "parseTag"
1142         n <- parseTagName
1143         v <- parseTagValue
1144         return (n,v)
1145
1146 parseTagName = do
1147         -- ptrace "parseTagName"
1148         n <- many1 $ noneOf ": \t"
1149         char ':'
1150         return n
1151
1152 parseTagValue = do
1153   -- ptrace "parseTagValue"
1154   v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof)
1155   return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
1156
1157 ledgerDateSyntaxToTags :: String -> String
1158 ledgerDateSyntaxToTags =
1159         regexReplaceBy "\\[[-.\\/0-9=]+\\]" replace
1160         where
1161                 replace ('[':s) | lastDef ' ' s == ']' = replace' $ init s
1162                 replace s = s
1163
1164                 replace' s | isdate s = datetag s
1165                 replace' ('=':s) | isdate s = date2tag s
1166                 replace' s | last s =='=' && isdate (init s) = datetag (init s)
1167                 replace' s | length ds == 2 && isdate d1 && isdate d1 = datetag d1 ++ date2tag d2
1168                         where
1169                                 ds = splitAtElement '=' s
1170                                 d1 = headDef "" ds
1171                                 d2 = lastDef "" ds
1172                 replace' s = s
1173
1174                 isdate = isJust . parsedateM
1175                 datetag s = "date:"++s++", "
1176                 date2tag s = "date2:"++s++", "
1177
1178 dateValueFromTags, date2ValueFromTags :: [Tag] -> Maybe String
1179 dateValueFromTags  ts = maybe Nothing (Just . snd) $ find ((=="date") . fst) ts
1180 date2ValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date2") . fst) ts
1181 -}