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