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