lib/Hcompta/Format/Ledger/Read.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 module Hcompta.Format.Ledger.Read where
   3
   4 import Control.Applicative ((<*))
   5 import qualified Control.Exception as Exn
   6 import Control.Monad
   7 -- import Control.Monad.Error
   8 import Data.Data
   9 import Data.List
  10 -- import Data.List.Split (wordsBy)
  11 import qualified Data.Map
  12 import Data.Maybe
  13 import Data.Typeable ()
  14 import Safe (headDef, lastDef)
  15 import Text.Printf
  16 import qualified Data.Time.Clock     as Time
  17 import qualified Data.Time.Calendar  as Time
  18 import qualified Data.Time.LocalTime as Time
  19 import Text.Parsec hiding (parse)
  20
  21 import Hcompta.Model as Model
  22 import Hcompta.Model.Account as Model.Account
  23 import Hcompta.Model.Amount as Model.Amount
  24 import Hcompta.Model.Date as Model.Date
  25 import Hcompta.Format.Ledger.Journal as Journal
  26
  27 data Context
  28  =   Context
  29  { account_prefix :: !Model.Account
  30  --, context_aliases :: ![AccountAlias]
  31  , unit_and_style :: !(Maybe (Model.Amount.Unit, Model.Amount.Style))
  32  , journal :: !Journal
  33  , year :: !Model.Date.Year
  34  } deriving (Data, Eq, Read, Show, Typeable)
  35
  36 null :: Context
  37 null =
  38         Context
  39          { account_prefix = []
  40          , unit_and_style = Nothing
  41          , journal = Journal.null
  42          , year = (\(year, _ , _) -> year) $
  43                 Time.toGregorian $ Time.utctDay $
  44                 Journal.last_read_time Journal.null
  45          }
  46
  47
  48
  49 {-
  50 reader :: Reader
  51 reader = Reader format detect parse
  52
  53 format :: String
  54 format = "ledger"
  55
  56 detect :: FilePath -> String -> Bool
  57 detect file s
  58         | file /= "-"  = takeExtension file `elem` ['.':format, ".j"]  -- from a file: yes if the extension is .journal or .j
  59         -- from stdin: yes if we can see something that looks like a journal entry (digits in column 0 with the next line indented)
  60         | otherwise = regexMatches "^[0-9]+.*\n[ \t]+" s
  61
  62 parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal
  63 parse _ = parseJournal journal
  64
  65 parseJournal
  66  :: ParsecT [Char] Context (ErrorT String IO) Context
  67  -> Bool -> FilePath -> String -> ErrorT String IO Journal
  68 parseJournal parser filePath fileData = do
  69         currentUTC <- liftIO Time.getCurrentTime
  70         currentTimeZone <- liftIO Time.getCurrentTimeZone
  71         let currentLocalTime = Time.utcToLocalTime currentTimeZone currentUTC
  72         let (currentLocalYear, _, _) = Time.toGregorian $ Time.localDay currentLocalTime
  73         parserResult <- runParserT parser
  74          contextNull{context_year=Just currentLocalYear}
  75          filePath fileData
  76         case parserResult of
  77          Left error -> throwError $ show error
  78          Right context -> do
  79                 let journal = context_journal context
  80                 journalBalanceTransactions $
  81                 journal
  82                  { journal_unit_styles=
  83                  , journal_file=filePath
  84                  , journal_includes=reverse $ journal_includes journal
  85                  -- , journal_historical_prices=reverse $ journal_historical_prices journal
  86                  , journal_last_read_time=currentUTC
  87                  , journal_transactions=reverse $ journal_transactions journal
  88                  -- , journal_transaction_modifiers=reverse $ journal_transaction_modifiers journal
  89                  -- , journal_transaction_periodics=reverse $ journal_transaction_periodics journal
  90                  }
  91
  92 -- | Fill in any missing amounts and check that all journal transactions
  93 -- balance, or return an error message. This is done after parsing all
  94 -- amounts and working out the canonical commodities, since balancing
  95 -- depends on display precision. Reports only the first error encountered.
  96 journalBalanceTransactions :: Journal -> Either String Journal
  97 journalBalanceTransactions journal =
  98         let transactions = journal_transactions journal
  99         let unit_and_style = journal_unit_styles journal
 100         case sequence $ map balance transactions of
 101          Right ts' -> Right journal{journal_transactions=map txnTieKnot ts'}
 102          Left e    -> Left e
 103         where balance = balanceTransaction (Just unit_and_style)
 104
 105 -- | Convert all the journal's posting amounts (not price amounts) to
 106 -- their canonical display settings. Ie, all amounts in a given
 107 -- unit will use (a) the display settings of the first, and (b)
 108 -- the greatest precision, of the posting amounts in that unit.
 109 journalCanonicaliseAmounts :: Journal -> Journal
 110 journalCanonicaliseAmounts j@Journal{journal_transactions=ts} =
 111         j''
 112         where
 113                 j'' = j'{journal_transactions=map fixtransaction ts}
 114                 j' = j{context_unit_and_style = canonicalStyles $ dbgAt 8 "journalAmounts" $ journalAmounts j}
 115                 fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps}
 116                 fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a}
 117                 fixmixedamount (Mixed as) = Mixed $ map fixamount as
 118                 fixamount a@Amount{aunit=c} = a{astyle=journalCommodityStyle j' c}
 119
 120 -- | Given a list of amounts in parse order, build a map from commodities
 121 -- to canonical display styles for amounts in that unit.
 122 canonicalStyles :: [Amount] -> M.Map Amount.Unit Amount.Style
 123 canonicalStyles amts =
 124         M.fromList commstyles
 125         where
 126                 samecomm = \a1 a2 -> aunit a1 == aunit a2
 127                 commamts = [(aunit $ head as, as) | as <- groupBy samecomm $ sortBy (comparing aunit) amts]
 128                 commstyles = [(c, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts]
 129
 130 -- | Get all this journal's component amounts, roughly in the order parsed.
 131 journalAmounts :: Journal -> [Amount]
 132 journalAmounts =
 133         concatMap flatten . journalMixedAmounts
 134         where flatten (Mixed as) = as
 135
 136 amountStyleFromCommodity :: Context -> Amount.Unit -> Amount.Style
 137 amountStyleFromCommodity context unit =
 138         Data.Map.findWithDefault
 139          (context_unit_and_style context)
 140          unit $
 141         journal_unit_styles $
 142         context_journal context
 143
 144
 145
 146
 147 setYear :: Stream [Char] m Char => Integer -> ParsecT [Char] Context m ()
 148 setYear y = modifyState (\ctx -> ctx{context_year=Just y})
 149
 150 getYear :: Stream [Char] m Char => ParsecT s Context m (Maybe Integer)
 151 getYear = liftM context_year getState
 152
 153 setCoA :: Stream [Char] m Char => CoA -> ParsecT [Char] Context m ()
 154 setCoA coa = modifyState (\ctx -> ctx{ctxCoA=coa})
 155
 156 getCoA :: Stream [Char] m Char => ParsecT [Char] Context m CoA
 157 getCoA = liftM ctxCoA getState
 158
 159 setDefaultCommodityAndStyle :: Stream [Char] m Char => (Amount.Unit,Amount.Style) -> ParsecT [Char] Context m ()
 160 setDefaultCommodityAndStyle cs = modifyState (\ctx -> ctx{context_unit_and_style=Just cs})
 161
 162 getDefaultCommodityAndStyle :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe (Amount.Unit,Amount.Style))
 163 getDefaultCommodityAndStyle = context_unit_and_style `fmap` getState
 164
 165 pushParentAccount :: Stream [Char] m Char => String -> ParsecT [Char] Context m ()
 166 pushParentAccount parent = modifyState addParentAccount
 167     where addParentAccount ctx0 = ctx0 { context_account_prefix = parent : context_account_prefix ctx0 }
 168
 169 popParentAccount :: Stream [Char] m Char => ParsecT [Char] Context m ()
 170 popParentAccount = do
 171         ctx0 <- getState
 172         case context_account_prefix ctx0 of
 173          [] -> unexpected "End of account block with no beginning"
 174          (_:rest) -> setState $ ctx0 { context_account_prefix = rest }
 175
 176 getParentAccount :: Stream [Char] m Char => ParsecT [Char] Context m String
 177 getParentAccount = liftM (concatAccountNames . reverse . context_account_prefix) getState
 178
 179 addAccountAlias :: Stream [Char] m Char => AccountAlias -> ParsecT [Char] Context m ()
 180 addAccountAlias a = modifyState (\(ctx@Ctx{..}) -> ctx{context_aliases=a:context_aliases})
 181
 182 getAccountAliases :: Stream [Char] m Char => ParsecT [Char] Context m [AccountAlias]
 183 getAccountAliases = liftM context_aliases getState
 184
 185 clearAccountAliases :: Stream [Char] m Char => ParsecT [Char] Context m ()
 186 clearAccountAliases = modifyState (\(ctx@Ctx{..}) -> ctx{context_aliases=[]})
 187
 188 -- parsers
 189
 190 parseJournal :: ParsecT [Char] Context (ErrorT String IO) (JournalUpdate, Context)
 191 parseJournal = do
 192         journalUpdates <- many journalItem
 193         eof
 194         finalContext <- getState
 195         return $ (combineJournalUpdates journalUpdates, finalContext)
 196                 where
 197                         -- As all journal line types can be distinguished by the first
 198                         -- character, excepting transactions versus empty (blank or
 199                         -- comment-only) lines, can use choice w/o try
 200                         journalItem =
 201                                 choice
 202                                  [ directive
 203                                  , liftM (return . addTransaction) parseTransaction
 204                                  , liftM (return . addModifierTransaction) parseTransactionModifier
 205                                  , liftM (return . addPeriodicTransaction) periodictransaction
 206                                  , liftM (return . addHistoricalPrice) historicalpricedirective
 207                                  , emptyorcommentlinep >> return (return id)
 208                                  , multilinecommentp >> return (return id)
 209                                  ] <?> "journal transaction or directive"
 210
 211 parseDirective :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 212 parseDirective = do
 213         optional $ char '!'
 214         choice'
 215          [ parseDirectiveInclude
 216          , parseDirectiveAlias
 217          , parseDirectiveEndAlias
 218          , parseDirectiveAccount
 219          , parseDirectiveEnd
 220          , parseDirectiveTag
 221          , parseDirectiveEndTag
 222          , parseDirectiveYear
 223          , parseDirectiveCommodity
 224          , parseDirectiveCommodityConversion
 225          , parseDirectiveIgnoredPriceCommodity
 226          ]
 227         <?> "directive"
 228
 229 parseDirectiveInclude :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 230 parseDirectiveInclude = do
 231         string "include"
 232         many1 spacenonewline
 233         filename <- restofline
 234         outerState <- getState
 235         outerPos <- getPosition
 236         let curdir = takeDirectory (sourceName outerPos)
 237         let (u::ErrorT String IO (Journal -> Journal, Context)) = do
 238                 filepath <- expandPath curdir filename
 239                 txt <- readFileOrError outerPos filepath
 240                 let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
 241                 r <- runParserT parseJournal outerState filepath txt
 242                 case r of
 243                  Right (ju, ctx) -> do
 244                         u <- combineJournalUpdates [ return $ journalAddFile (filepath,txt)
 245                                                    , ju
 246                                                    ] `catchError` (throwError . (inIncluded ++))
 247                         return (u, ctx)
 248                  Left err -> throwError $ inIncluded ++ show err
 249                 where readFileOrError pos fp =
 250                         ErrorT $ liftM Right (readFile' fp) `Exn.catch`
 251                           \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::Exn.IOException))
 252         r <- liftIO $ runErrorT u
 253         case r of
 254          Left err -> return $ throwError err
 255          Right (ju, ctx) -> do
 256                 setCoA (ctxCoA ctx)
 257                 return $ ErrorT $ return $ Right ju
 258
 259 journalAddFile :: (FilePath,String) -> Journal -> Journal
 260 journalAddFile f j@Journal{journal_files=fs} = j{journal_files=fs++[f]}
 261  -- NOTE: first encountered file to left, to avoid a reverse
 262
 263 parseDirectiveAccount :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 264 parseDirectiveAccount = do
 265   string "account"
 266   many1 spacenonewline
 267   parent <- parseAccountName
 268   newline
 269   pushParentAccount parent
 270   -- return $ return id
 271   return $ ErrorT $ return $ Right id
 272
 273 parseDirectiveEnd :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 274 parseDirectiveEnd = do
 275   string "end"
 276   popParentAccount
 277   -- return (return id)
 278   return $ ErrorT $ return $ Right id
 279
 280 parseDirectiveAlias :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 281 parseDirectiveAlias = do
 282   string "alias"
 283   many1 spacenonewline
 284   orig <- many1 $ noneOf "="
 285   char '='
 286   alias <- restofline
 287   addAccountAlias (accountNameWithoutPostingType $ strip orig
 288                   ,accountNameWithoutPostingType $ strip alias)
 289   return $ return id
 290
 291 parseDirectiveEndAlias :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 292 parseDirectiveEndAlias = do
 293   string "end aliases"
 294   clearAccountAliases
 295   return (return id)
 296
 297 parseDirectiveTag :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 298 parseDirectiveTag = do
 299   string "tag" <?> "tag directive"
 300   many1 spacenonewline
 301   _ <- many1 nonspace
 302   restofline
 303   return $ return id
 304
 305 parseDirectiveEndTag :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 306 parseDirectiveEndTag = do
 307         (string "end tag" <|> string "pop") <?> "end tag or pop directive"
 308         restofline
 309         return $ return id
 310
 311 parseDirectiveYear :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 312 parseDirectiveYear = do
 313         char 'Y' <?> "default year"
 314         many spacenonewline
 315         y <- many1 digit
 316         let y' = read y
 317         failIfInvalidYear y
 318         setYear y'
 319         return $ return id
 320
 321 parseDirectiveCommodity :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 322 parseDirectiveCommodity = do
 323         char 'D' <?> "default unit"
 324         many1 spacenonewline
 325         Amount{..} <- getDefaultCommodityAndStyle >>= parseAmount
 326         setDefaultCommodityAndStyle (aunit, astyle)
 327         restofline
 328         return $ return id
 329
 330 parseDirectiveHistoricalPrice :: ParsecT [Char] Context (ErrorT String IO) HistoricalPrice
 331 parseDirectiveHistoricalPrice = do
 332         char 'P' <?> "historical price"
 333         many spacenonewline
 334         date <- try (do {LocalTime d _ <- parseDateTime; return d}) <|> parseDate -- a time is ignored
 335         many1 spacenonewline
 336         symbol <- parseCommodity
 337         many spacenonewline
 338         price <- getDefaultCommodityAndStyle >>= parseAmount
 339         restofline
 340         return $ HistoricalPrice date symbol price
 341
 342 parseDirectiveIgnoredPriceCommodity :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 343 parseDirectiveIgnoredPriceCommodity = do
 344         char 'N' <?> "ignored-price unit"
 345         many1 spacenonewline
 346         parseCommodity
 347         restofline
 348         return $ return id
 349
 350 parseDirectiveCommodityConversion :: ParsecT [Char] Context (ErrorT String IO) JournalUpdate
 351 parseDirectiveCommodityConversion = do
 352         char 'C' <?> "unit conversion"
 353         many1 spacenonewline
 354         default_cs <- getDefaultCommodityAndStyle
 355         parseAmount default_cs
 356         many spacenonewline
 357         char '='
 358         many spacenonewline
 359         parseAmount default_cs
 360         restofline
 361         return $ return id
 362
 363 parseTransactionModifier :: ParsecT [Char] Context (ErrorT String IO) ModifierTransaction
 364 parseTransactionModifier = do
 365         char '=' <?> "modifier transaction"
 366         many spacenonewline
 367         valueexpr <- restofline
 368         parsePostings <- parsePostings
 369         return $ ModifierTransaction valueexpr parsePostings
 370
 371 parseTransactionPeriodic :: ParsecT [Char] Context (ErrorT String IO) PeriodicTransaction
 372 parseTransactionPeriodic = do
 373         char '~' <?> "periodic transaction"
 374         many spacenonewline
 375         periodexpr <- restofline
 376         parsePostings <- parsePostings
 377         return $ PeriodicTransaction periodexpr parsePostings
 378
 379 -- | Parse a (possibly unbalanced) transaction.
 380 parseTransaction :: ParsecT [Char] Context (ErrorT String IO) Transaction
 381 parseTransaction = do
 382         -- ptrace "transaction"
 383         sourcepos <- getPosition
 384         date <- parseDate <?> "transaction"
 385         edate <- optionMaybe (parseDate2 date) <?> "secondary date"
 386         lookAhead (spacenonewline <|> newline) <?> "whitespace or newline"
 387         status <- parseStatus <?> "cleared flag"
 388         code <- parseCode <?> "transaction code"
 389         description <- descriptionp >>= return . strip
 390         comment <- try followingcommentp <|> (newline >> return "")
 391         let tags = tagsInComment comment
 392         parsePostings <- parsePostings
 393         return $ txnTieKnot $ Transaction sourcepos date edate status code description comment tags parsePostings ""
 394
 395 descriptionp = many (noneOf ";\n")
 396
 397 -- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year
 398 -- may be omitted if a default year has already been set.
 399 parseDate :: Stream [Char] m t => ParsecT [Char] Context m Day
 400 parseDate = do
 401         -- hacky: try to ensure precise errors for invalid dates
 402         -- XXX reported error position is not too good
 403         -- pos <- getPosition
 404         datestr <- many1 $ choice' [digit, datesepchar]
 405         let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
 406         when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
 407         let dateparts = wordsBy (`elem` datesepchars) datestr
 408         currentyear <- getYear
 409         [y, m, d] <-
 410                 case (dateparts,currentyear) of
 411                  ([m,d],Just y)  -> return [show y,m,d]
 412                  ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown"
 413                  ([y,m,d],_)     -> return [y,m,d]
 414                  _               -> fail $ "bad date: " ++ datestr
 415         let maybedate = fromGregorianValid (read y) (read m) (read d)
 416         case maybedate of
 417          Nothing   -> fail $ "bad date: " ++ datestr
 418          Just date -> return date
 419         <?> "full or partial date"
 420
 421 -- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format.  Any
 422 -- timezone will be ignored; the time is treated as local time.  Fewer
 423 -- digits are allowed, except in the timezone. The year may be omitted if
 424 -- a default year has already been set.
 425 parseDateTime :: Stream [Char] m Char => ParsecT [Char] Context m LocalTime
 426 parseDateTime = do
 427         day <- parseDate
 428         many1 spacenonewline
 429         h <- many1 digit
 430         let h' = read h
 431         guard $ h' >= 0 && h' <= 23
 432         char ':'
 433         m <- many1 digit
 434         let m' = read m
 435         guard $ m' >= 0 && m' <= 59
 436         s <- optionMaybe $ char ':' >> many1 digit
 437         let s' = case s of Just sstr -> read sstr
 438                            Nothing   -> 0
 439         guard $ s' >= 0 && s' <= 59
 440         {- tz <- -}
 441         optionMaybe $ do
 442                 plusminus <- oneOf "-+"
 443                 d1 <- digit
 444                 d2 <- digit
 445                 d3 <- digit
 446                 d4 <- digit
 447                 return $ plusminus:d1:d2:d3:d4:""
 448         -- ltz <- liftIO $ getCurrentTimeZone
 449         -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
 450         -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
 451         return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
 452
 453 parseDate2 :: Stream [Char] m Char => Day -> ParsecT [Char] Context m Day
 454 parseDate2 primarydate = do
 455         char '='
 456         -- kludgy way to use primary date for default year
 457         let withDefaultYear d p = do
 458                 y <- getYear
 459                 let (y',_,_) = toGregorian d in setYear y'
 460                 r <- p
 461                 when (isJust y) $ setYear $ fromJust y
 462                 return r
 463         edate <- withDefaultYear primarydate parseDate
 464         return edate
 465
 466 parseStatus :: Stream [Char] m Char => ParsecT [Char] Context m Bool
 467 parseStatus = try (do { many spacenonewline; (char '*' <|> char '!') <?> "status"; return True } ) <|> return False
 468
 469 parseCode :: Stream [Char] m Char => ParsecT [Char] Context m String
 470 parseCode = try (do { many1 spacenonewline; char '(' <?> "parseCode"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
 471
 472 -- Parse the following whitespace-beginning lines as parsePostings, posting tags, and/or comments.
 473 parsePostings :: Stream [Char] m Char => ParsecT [Char] Context m [Posting]
 474 parsePostings = many1 (try parsePosting) <?> "parsePostings"
 475
 476 parsePosting :: Stream [Char] m Char => ParsecT [Char] Context m Posting
 477 parsePosting = do
 478         many1 spacenonewline
 479         status <- parseStatus
 480         many spacenonewline
 481         account <- modifiedaccountname
 482         let (ptype, account') = (accountNamePostingType account, unbracket account)
 483         amount <- spaceandamountormissing
 484         massertion <- partialbalanceassertion
 485         _ <- fixedlotprice
 486         many spacenonewline
 487         ctx <- getState
 488         comment <- try followingcommentp <|> (newline >> return "")
 489         let tags = tagsInComment comment
 490         coa <- getCoA
 491         pcoa <-
 492                 if isZeroMixedAmount amount
 493                 then do
 494                         let coa_ = coaAdd coa (accountNameComponents account) tags
 495                         setCoA coa_
 496                         return coa_
 497                 else return coa
 498         date <-
 499                 case dateValueFromTags tags of
 500                  Nothing -> return Nothing
 501                  Just v ->
 502                         case runParser (parseDate <* eof) ctx "" v of
 503                          Right d -> return $ Just d
 504                          Left err -> parserFail $ show err
 505         date2 <-
 506                 case date2ValueFromTags tags of
 507                  Nothing -> return Nothing
 508                  Just v ->
 509                         case runParser (parseDate <* eof) ctx "" v of
 510                          Right d -> return $ Just d
 511                          Left err -> parserFail $ show err
 512         return posting
 513          { Posting.date=date
 514          , Posting.date2=date2
 515          , Posting.status=status
 516          , Posting.account=account'
 517          , Posting.amount=amount
 518          , Posting.comment=comment
 519          , Posting.type=ptype
 520          , Posting.tags=tags
 521          , Posting.coa=pcoa
 522          , Posting.balanceassertion=massertion
 523          }
 524
 525
 526 -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
 527 modifiedaccountname :: Stream [Char] m Char => ParsecT [Char] Context m AccountName
 528 modifiedaccountname = do
 529   a <- parseAccountName
 530   prefix <- getParentAccount
 531   let prefixed = prefix `joinAccountNames` a
 532   aliases <- getAccountAliases
 533   return $ accountNameApplyAliases aliases prefixed
 534
 535 -- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace
 536 --     <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"
 537
 538 -- | Parse whitespace then an amount, with an optional left or right
 539 -- currency symbol and optional price, or return the special
 540 -- "missing" marker amount.
 541 spaceandamountormissing :: Stream [Char] m Char => ParsecT [Char] Context m MixedAmount
 542 spaceandamountormissing = do
 543   default_cs <- getDefaultCommodityAndStyle
 544   try (do
 545         many1 spacenonewline
 546         (Mixed . (:[])) `fmap` parseAmount default_cs <|> return missingmixedamt
 547       ) <|> return missingmixedamt
 548
 549 partialbalanceassertion :: Stream [Char] m t => ParsecT [Char] Context m (Maybe MixedAmount)
 550 partialbalanceassertion = do
 551     default_cs <- getDefaultCommodityAndStyle
 552     try (do
 553           many spacenonewline
 554           char '='
 555           many spacenonewline
 556           a <- parseAmount default_cs -- XXX should restrict to a simple amount
 557           return $ Just $ Mixed [a])
 558          <|> return Nothing
 559
 560 -- balanceassertion :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe MixedAmount)
 561 -- balanceassertion =
 562 --     default_cs <- getDefaultCommodityAndStyle
 563 --     try (do
 564 --           many spacenonewline
 565 --           string "=="
 566 --           many spacenonewline
 567 --           a <- parseAmount default_cs -- XXX should restrict to a simple amount
 568 --           return $ Just $ Mixed [a])
 569 --          <|> return Nothing
 570
 571 -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
 572 fixedlotprice :: Stream [Char] m Char => ParsecT [Char] Context m (Maybe Amount)
 573 fixedlotprice = do
 574     default_cs <- getDefaultCommodityAndStyle
 575     try (do
 576           many spacenonewline
 577           char '{'
 578           many spacenonewline
 579           char '='
 580           many spacenonewline
 581           a <- parseAmount default_cs -- XXX should restrict to a simple amount
 582           many spacenonewline
 583           char '}'
 584           return $ Just a)
 585          <|> return Nothing
 586
 587 -- comment parsers
 588
 589 multilinecommentp :: Stream [Char] m Char => ParsecT [Char] Context m ()
 590 multilinecommentp = do
 591   string "comment" >> newline
 592   go
 593   where
 594     go = try (string "end comment" >> newline >> return ())
 595          <|> (anyLine >> go)
 596     anyLine = anyChar `manyTill` newline
 597
 598 emptyorcommentlinep :: Stream [Char] m Char => ParsecT [Char] Context m ()
 599 emptyorcommentlinep = do
 600   many spacenonewline >> (parseComment <|> (many spacenonewline >> newline >> return ""))
 601   return ()
 602
 603 followingcommentp :: Stream [Char] m Char => ParsecT [Char] Context m String
 604 followingcommentp =
 605   -- ptrace "followingcommentp"
 606   do samelinecomment <- many spacenonewline >> (try semicoloncomment <|> (newline >> return ""))
 607      newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment))
 608      return $ unlines $ samelinecomment:newlinecomments
 609
 610 parseComment :: Stream [Char] m Char => ParsecT [Char] Context m String
 611 parseComment = commentStartingWith commentchars
 612
 613 commentchars :: [Char]
 614 commentchars = "#;*"
 615
 616 semicoloncomment :: Stream [Char] m Char => ParsecT [Char] Context m String
 617 semicoloncomment = commentStartingWith ";"
 618
 619 commentStartingWith :: Stream [Char] m Char => String -> ParsecT [Char] Context m String
 620 commentStartingWith cs = do
 621   -- ptrace "commentStartingWith"
 622   oneOf cs
 623   many spacenonewline
 624   l <- anyChar `manyTill` eolof
 625   optional newline
 626   return l
 627
 628 tagsInComment :: String -> [Tag]
 629 tagsInComment c = concatMap tagsInCommentLine $ lines c'
 630   where
 631     c' = ledgerDateSyntaxToTags c
 632
 633 tagsInCommentLine :: String -> [Tag]
 634 tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ','
 635   where
 636     maybetag s = case runParser (parseTag <* eof) contextNull "" s of
 637                   Right t -> Just t
 638                   Left _ -> Nothing
 639
 640 parseTag = do
 641         -- ptrace "parseTag"
 642         n <- parseTagName
 643         v <- parseTagValue
 644         return (n,v)
 645
 646 parseTagName = do
 647         -- ptrace "parseTagName"
 648         n <- many1 $ noneOf ": \t"
 649         char ':'
 650         return n
 651
 652 parseTagValue = do
 653   -- ptrace "parseTagValue"
 654   v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof)
 655   return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v
 656
 657 ledgerDateSyntaxToTags :: String -> String
 658 ledgerDateSyntaxToTags =
 659         regexReplaceBy "\\[[-.\\/0-9=]+\\]" replace
 660         where
 661                 replace ('[':s) | lastDef ' ' s == ']' = replace' $ init s
 662                 replace s = s
 663
 664                 replace' s | isdate s = datetag s
 665                 replace' ('=':s) | isdate s = date2tag s
 666                 replace' s | last s =='=' && isdate (init s) = datetag (init s)
 667                 replace' s | length ds == 2 && isdate d1 && isdate d1 = datetag d1 ++ date2tag d2
 668                         where
 669                                 ds = splitAtElement '=' s
 670                                 d1 = headDef "" ds
 671                                 d2 = lastDef "" ds
 672                 replace' s = s
 673
 674                 isdate = isJust . parsedateM
 675                 datetag s = "date:"++s++", "
 676                 date2tag s = "date2:"++s++", "
 677
 678 dateValueFromTags, date2ValueFromTags :: [Tag] -> Maybe String
 679 dateValueFromTags  ts = maybe Nothing (Just . snd) $ find ((=="date") . fst) ts
 680 date2ValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date2") . fst) ts
 681 -}