journal: more flexible, Ledger-compatible parsing of lot prices
We now accept (but still ignore) a fixed or nonfixed ({=} or {}) lot
price following a posting amount, and it may appear before or after a
transaction price (@ or @@). And it may no longer appear after a
balance assertion.
Also: fixedlotpricep renamed to lotpricep, now also parses non-fixed
lot prices. A bit of amount parsers cleanup.
			
			
This commit is contained in:
		
							parent
							
								
									10f8dc84a5
								
							
						
					
					
						commit
						ea3b290dd0
					
				@ -84,7 +84,7 @@ module Hledger.Read.Common (
 | 
				
			|||||||
  commoditysymbolp,
 | 
					  commoditysymbolp,
 | 
				
			||||||
  priceamountp,
 | 
					  priceamountp,
 | 
				
			||||||
  balanceassertionp,
 | 
					  balanceassertionp,
 | 
				
			||||||
  fixedlotpricep,
 | 
					  lotpricep,
 | 
				
			||||||
  numberp,
 | 
					  numberp,
 | 
				
			||||||
  fromRawNumber,
 | 
					  fromRawNumber,
 | 
				
			||||||
  rawnumberp,
 | 
					  rawnumberp,
 | 
				
			||||||
@ -603,14 +603,27 @@ spaceandamountormissingp =
 | 
				
			|||||||
    lift $ skipSome spacenonewline
 | 
					    lift $ skipSome spacenonewline
 | 
				
			||||||
    Mixed . (:[]) <$> amountp
 | 
					    Mixed . (:[]) <$> amountp
 | 
				
			||||||
 | 
					
 | 
				
			||||||
-- | Parse a single-commodity amount, with optional symbol on the left or
 | 
					-- | Parse a single-commodity amount, with optional symbol on the left
 | 
				
			||||||
-- right, optional unit or total price, and optional (ignored)
 | 
					-- or right, followed by an optional transaction price (@ or @@), and
 | 
				
			||||||
-- ledger-style balance assertion or fixed lot price declaration.
 | 
					-- an optional ledger-style lot price ({} or {=}). The lot price will
 | 
				
			||||||
 | 
					-- be ignored, and may appear before or after the transaction price.
 | 
				
			||||||
amountp :: JournalParser m Amount
 | 
					amountp :: JournalParser m Amount
 | 
				
			||||||
amountp = label "amount" $ do
 | 
					amountp = label "amount" $ do
 | 
				
			||||||
 | 
					  let spaces = lift $ skipMany spacenonewline
 | 
				
			||||||
  amount <- amountwithoutpricep
 | 
					  amount <- amountwithoutpricep
 | 
				
			||||||
  lift $ skipMany spacenonewline
 | 
					  spaces
 | 
				
			||||||
  mprice <- priceamountp
 | 
					  _elotprice <- optional $ lotpricep <* spaces
 | 
				
			||||||
 | 
					  mprice <- optional $ priceamountp <* spaces
 | 
				
			||||||
 | 
					  _elotprice <- optional $ lotpricep
 | 
				
			||||||
 | 
					  pure $ amount { aprice = mprice }
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					-- XXX Just like amountp but don't allow lot prices. Needed for balanceassertionp.
 | 
				
			||||||
 | 
					amountpnolotprices :: JournalParser m Amount
 | 
				
			||||||
 | 
					amountpnolotprices = label "amount" $ do
 | 
				
			||||||
 | 
					  let spaces = lift $ skipMany spacenonewline
 | 
				
			||||||
 | 
					  amount <- amountwithoutpricep
 | 
				
			||||||
 | 
					  spaces
 | 
				
			||||||
 | 
					  mprice <- optional $ priceamountp <* spaces
 | 
				
			||||||
  pure $ amount { aprice = mprice }
 | 
					  pure $ amount { aprice = mprice }
 | 
				
			||||||
 | 
					
 | 
				
			||||||
amountwithoutpricep :: JournalParser m Amount
 | 
					amountwithoutpricep :: JournalParser m Amount
 | 
				
			||||||
@ -720,15 +733,16 @@ quotedcommoditysymbolp =
 | 
				
			|||||||
simplecommoditysymbolp :: TextParser m CommoditySymbol
 | 
					simplecommoditysymbolp :: TextParser m CommoditySymbol
 | 
				
			||||||
simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar)
 | 
					simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
priceamountp :: JournalParser m (Maybe AmountPrice)
 | 
					priceamountp :: JournalParser m AmountPrice
 | 
				
			||||||
priceamountp = option Nothing $ do
 | 
					priceamountp = (do
 | 
				
			||||||
  char '@'
 | 
					  char '@'
 | 
				
			||||||
  priceConstructor <- char '@' *> pure TotalPrice <|> pure UnitPrice
 | 
					  priceConstructor <- char '@' *> pure TotalPrice <|> pure UnitPrice
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  lift (skipMany spacenonewline)
 | 
					  lift (skipMany spacenonewline)
 | 
				
			||||||
  priceAmount <- amountwithoutpricep <?> "unpriced amount (specifying a price)"
 | 
					  priceAmount <- amountwithoutpricep -- <?> "unpriced amount (specifying a price)"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  pure $ Just $ priceConstructor priceAmount
 | 
					  pure $ priceConstructor priceAmount
 | 
				
			||||||
 | 
					  ) <?> "price amount"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
balanceassertionp :: JournalParser m BalanceAssertion
 | 
					balanceassertionp :: JournalParser m BalanceAssertion
 | 
				
			||||||
balanceassertionp = do
 | 
					balanceassertionp = do
 | 
				
			||||||
@ -739,7 +753,7 @@ balanceassertionp = do
 | 
				
			|||||||
  lift (skipMany spacenonewline)
 | 
					  lift (skipMany spacenonewline)
 | 
				
			||||||
  -- this amount can have a price; balance assertions ignore it,
 | 
					  -- this amount can have a price; balance assertions ignore it,
 | 
				
			||||||
  -- but balance assignments will use it
 | 
					  -- but balance assignments will use it
 | 
				
			||||||
  a <- amountp <?> "amount (for a balance assertion or assignment)"
 | 
					  a <- amountpnolotprices <?> "amount (for a balance assertion or assignment)"
 | 
				
			||||||
  return BalanceAssertion
 | 
					  return BalanceAssertion
 | 
				
			||||||
    { baamount    = a
 | 
					    { baamount    = a
 | 
				
			||||||
    , batotal     = istotal
 | 
					    , batotal     = istotal
 | 
				
			||||||
@ -747,22 +761,19 @@ balanceassertionp = do
 | 
				
			|||||||
    , baposition  = sourcepos
 | 
					    , baposition  = sourcepos
 | 
				
			||||||
    }
 | 
					    }
 | 
				
			||||||
 | 
					
 | 
				
			||||||
-- Parse a Ledger-style fixed lot price: {=PRICE}
 | 
					-- Parse a Ledger-style fixed {=PRICE} or non-fixed {PRICE} lot price,
 | 
				
			||||||
 | 
					-- as a Left or Right Amount respectively.
 | 
				
			||||||
-- https://www.ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices .
 | 
					-- https://www.ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices .
 | 
				
			||||||
-- Currently we ignore these (hledger's @ PRICE is equivalent),
 | 
					lotpricep :: JournalParser m (Either Amount Amount)
 | 
				
			||||||
-- and we don't parse a Ledger-style {PRICE} (equivalent to Ledger's @ PRICE).
 | 
					lotpricep = (do
 | 
				
			||||||
fixedlotpricep :: JournalParser m (Maybe Amount)
 | 
					 | 
				
			||||||
fixedlotpricep = optional $ do
 | 
					 | 
				
			||||||
  try $ do
 | 
					 | 
				
			||||||
    lift (skipMany spacenonewline)
 | 
					 | 
				
			||||||
  char '{'
 | 
					  char '{'
 | 
				
			||||||
 | 
					  fixed <- fmap isJust $ optional $ lift (skipMany spacenonewline) >> char '='
 | 
				
			||||||
  lift (skipMany spacenonewline)
 | 
					  lift (skipMany spacenonewline)
 | 
				
			||||||
  char '='
 | 
					  a <- amountwithoutpricep
 | 
				
			||||||
  lift (skipMany spacenonewline)
 | 
					 | 
				
			||||||
  a <- amountwithoutpricep <?> "unpriced amount (for an ignored ledger-style fixed lot price)"
 | 
					 | 
				
			||||||
  lift (skipMany spacenonewline)
 | 
					  lift (skipMany spacenonewline)
 | 
				
			||||||
  char '}'
 | 
					  char '}'
 | 
				
			||||||
  return a
 | 
					  return $ (if fixed then Left else Right) a
 | 
				
			||||||
 | 
					  ) <?> "ledger-style lot price or fixed lot price"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
-- | Parse a string representation of a number for its value and display
 | 
					-- | Parse a string representation of a number for its value and display
 | 
				
			||||||
-- attributes.
 | 
					-- attributes.
 | 
				
			||||||
 | 
				
			|||||||
@ -716,8 +716,7 @@ postingp mTransactionYear = do
 | 
				
			|||||||
  lift (skipMany spacenonewline)
 | 
					  lift (skipMany spacenonewline)
 | 
				
			||||||
  amount <- option missingmixedamt $ Mixed . (:[]) <$> amountp
 | 
					  amount <- option missingmixedamt $ Mixed . (:[]) <$> amountp
 | 
				
			||||||
  lift (skipMany spacenonewline)
 | 
					  lift (skipMany spacenonewline)
 | 
				
			||||||
  massertion <- optional $ balanceassertionp
 | 
					  massertion <- optional balanceassertionp
 | 
				
			||||||
  _ <- fixedlotpricep
 | 
					 | 
				
			||||||
  lift (skipMany spacenonewline)
 | 
					  lift (skipMany spacenonewline)
 | 
				
			||||||
  (comment,tags,mdate,mdate2) <- lift $ postingcommentp mTransactionYear
 | 
					  (comment,tags,mdate,mdate2) <- lift $ postingcommentp mTransactionYear
 | 
				
			||||||
  return posting
 | 
					  return posting
 | 
				
			||||||
@ -856,7 +855,9 @@ tests_JournalReader = tests "JournalReader" [
 | 
				
			|||||||
 | 
					
 | 
				
			||||||
    ,test "quoted commodity symbol with digits" $ assertParse (postingp Nothing) "  a  1 \"DE123\"\n"
 | 
					    ,test "quoted commodity symbol with digits" $ assertParse (postingp Nothing) "  a  1 \"DE123\"\n"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
    ,test "balance assertion and fixed lot price" $ assertParse (postingp Nothing) "  a  1 \"DE123\" =$1 { =2.2 EUR} \n"
 | 
					    ,test "lot price before transaction price" $ assertParse (postingp Nothing) "  a  1A {1B} @ 1B\n"
 | 
				
			||||||
 | 
					    ,test "lot price after transaction price" $ assertParse (postingp Nothing) "  a  1A @ 1B {1B}\n"
 | 
				
			||||||
 | 
					    ,test "lot price after balance assertion not allowed" $ assertParseError (postingp Nothing) "  a  1A @ 1B = 1A {1B}\n" "unexpected '{'"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
    ,test "balance assertion over entire contents of account" $ assertParse (postingp Nothing) "  a  $1 == $1\n"
 | 
					    ,test "balance assertion over entire contents of account" $ assertParse (postingp Nothing) "  a  $1 == $1\n"
 | 
				
			||||||
    ]
 | 
					    ]
 | 
				
			||||||
 | 
				
			|||||||
		Loading…
	
		Reference in New Issue
	
	Block a user