Merge pull request #819 from awjchen/moreParseErrors

Improving parse errors

hledger-lib/Hledger/Read/Common.hs

@@ -328,9 +328,13 @@ statusp =
     ]
 
 codep :: TextParser m Text
-codep = option "" $ try $ do
+codep = option "" $ do
+  try $ do
     skipSome spacenonewline
-  between (char '(') (char ')') $ takeWhileP Nothing (/= ')')
+    char '('
+  code <- takeWhileP Nothing $ \c -> c /= ')' && c /= '\n'
+  char ')' <?> "closing bracket ')' for transaction code"
+  pure code
 
 descriptionp :: TextParser m Text
 descriptionp = takeWhileP Nothing (not . semicolonOrNewline)
@@ -399,31 +403,55 @@ datep' mYear = do
 -- Leading zeroes may be omitted (except in a timezone).
 datetimep :: JournalParser m LocalTime
 datetimep = do
-  day <- datep
+  mYear <- getYear
-  lift $ skipSome spacenonewline
+  lift $ datetimep' mYear
-  h <- some digitChar
+
-  let h' = read h
+datetimep' :: Maybe Year -> TextParser m LocalTime
-  guard $ h' >= 0 && h' <= 23
+datetimep' mYear = do
-  char ':'
+  day <- datep' mYear
-  m <- some digitChar
+  skipSome spacenonewline
-  let m' = read m
+  time <- timeOfDay
-  guard $ m' >= 0 && m' <= 59
+  optional timeZone -- ignoring time zones
-  s <- optional $ char ':' >> some digitChar
+  pure $ LocalTime day time
-  let s' = case s of Just sstr -> read sstr
+
-                     Nothing   -> 0
+  where
-  guard $ s' >= 0 && s' <= 59
+    timeOfDay :: TextParser m TimeOfDay
-  {- tz <- -}
+    timeOfDay = do
-  optional $ do
+      pos1 <- getPosition
-                   plusminus <- oneOf ("-+" :: [Char])
+      h' <- twoDigitDecimal <?> "hour"
-                   d1 <- digitChar
+      pos2 <- getPosition
-                   d2 <- digitChar
+      unless (h' >= 0 && h' <= 23) $ parseErrorAtRegion pos1 pos2
-                   d3 <- digitChar
+        "invalid time (bad hour)"
-                   d4 <- digitChar
+
-                   return $ plusminus:d1:d2:d3:d4:""
+      char ':' <?> "':' (hour-minute separator)"
-  -- ltz <- liftIO $ getCurrentTimeZone
+      pos3 <- getPosition
-  -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
+      m' <- twoDigitDecimal <?> "minute"
-  -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
+      pos4 <- getPosition
-  return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
+      unless (m' >= 0 && m' <= 59) $ parseErrorAtRegion pos3 pos4
+        "invalid time (bad minute)"
+
+      s' <- option 0 $ do
+        char ':' <?> "':' (minute-second separator)"
+        pos5 <- getPosition
+        s' <- twoDigitDecimal <?> "second"
+        pos6 <- getPosition
+        unless (s' >= 0 && s' <= 59) $ parseErrorAtRegion pos5 pos6
+          "invalid time (bad second)" -- we do not support leap seconds
+        pure s'
+
+      pure $ TimeOfDay h' m' (fromIntegral s')
+
+    twoDigitDecimal :: TextParser m Int
+    twoDigitDecimal = do
+      d1 <- digitToInt <$> digitChar
+      d2 <- digitToInt <$> (digitChar <?> "a second digit")
+      pure $ d1*10 + d2
+
+    timeZone :: TextParser m String
+    timeZone = do
+      plusminus <- satisfy $ \c -> c == '-' || c == '+'
+      fourDigits <- count 4 (digitChar <?> "a digit (for a time zone)")
+      pure $ plusminus:fourDigits
 
 secondarydatep :: Day -> TextParser m Day
 secondarydatep primaryDate = char '=' *> datep' (Just primaryYear)
@@ -493,14 +521,85 @@ test_spaceandamountormissingp = do
 -- right, optional unit or total price, and optional (ignored)
 -- ledger-style balance assertion or fixed lot price declaration.
 amountp :: JournalParser m Amount
-amountp = do
+amountp = label "amount" $ do
   amount <- amountwithoutpricep
+  lift $ skipMany spacenonewline
   price <- priceamountp
   pure $ amount { aprice = price }
 
 amountwithoutpricep :: JournalParser m Amount
-amountwithoutpricep =
+amountwithoutpricep = do
-  try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp
+  (mult, sign) <- lift $ (,) <$> multiplierp <*> signp
+  leftsymbolamountp mult sign <|> rightornosymbolamountp mult sign
+
+  where
+
+  leftsymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount
+  leftsymbolamountp mult sign = label "amount" $ do
+    c <- lift commoditysymbolp
+    suggestedStyle <- getAmountStyle c
+
+    commodityspaced <- lift $ skipMany' spacenonewline
+
+    sign2 <- lift $ signp
+    posBeforeNum <- getPosition
+    ambiguousRawNum <- lift rawnumberp
+    mExponent <- lift $ optional $ try exponentp
+    posAfterNum <- getPosition
+    let numRegion = (posBeforeNum, posAfterNum)
+
+    (q,prec,mdec,mgrps) <- lift $
+      interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent
+    let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
+    return $ Amount c (sign (sign2 q)) NoPrice s mult
+
+  rightornosymbolamountp
+    :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount
+  rightornosymbolamountp mult sign = label "amount" $ do
+    posBeforeNum <- getPosition
+    ambiguousRawNum <- lift rawnumberp
+    mExponent <- lift $ optional $ try exponentp
+    posAfterNum <- getPosition
+    let numRegion = (posBeforeNum, posAfterNum)
+
+    mSpaceAndCommodity <- lift $ optional $ try $
+      (,) <$> skipMany' spacenonewline <*> commoditysymbolp
+
+    case mSpaceAndCommodity of
+      Just (commodityspaced, c) -> do
+        suggestedStyle <- getAmountStyle c
+        (q,prec,mdec,mgrps) <- lift $
+          interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent
+
+        let s = amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
+        return $ Amount c (sign q) NoPrice s mult
+
+      Nothing -> do
+        suggestedStyle <- getDefaultAmountStyle
+        (q,prec,mdec,mgrps) <- lift $
+          interpretNumber numRegion suggestedStyle ambiguousRawNum mExponent
+
+        -- apply the most recently seen default commodity and style to this commodityless amount
+        defcs <- getDefaultCommodityAndStyle
+        let (c,s) = case defcs of
+              Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec})
+              Nothing          -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps})
+        return $ Amount c (sign q) NoPrice s mult
+
+  -- For reducing code duplication. Doesn't parse anything. Has the type
+  -- of a parser only in order to throw parse errors (for convenience).
+  interpretNumber
+    :: (SourcePos, SourcePos)
+    -> Maybe AmountStyle
+    -> Either AmbiguousNumber RawNumber
+    -> Maybe Int
+    -> TextParser m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
+  interpretNumber posRegion suggestedStyle ambiguousNum mExp =
+    let rawNum = either (disambiguateNumber suggestedStyle) id ambiguousNum
+    in  case fromRawNumber rawNum mExp of
+          Left errMsg -> uncurry parseErrorAtRegion posRegion errMsg
+          Right res -> pure res
+
 
 #ifdef TESTS
 test_amountp = do
@@ -545,50 +644,6 @@ skipMany' p = go False
         then go True
         else pure isNull
 
-leftsymbolamountp :: JournalParser m Amount
-leftsymbolamountp = do
-  sign <- lift signp
-  m <- lift multiplierp
-  c <- lift commoditysymbolp
-  suggestedStyle <- getAmountStyle c
-  commodityspaced <- lift $ skipMany' spacenonewline
-  (q,prec,mdec,mgrps) <- lift $ numberp suggestedStyle
-  let s = amountstyle{ascommodityside=L, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
-  return $ Amount c (sign q) NoPrice s m
-  <?> "left-symbol amount"
-
-rightsymbolamountp :: JournalParser m Amount
-rightsymbolamountp = do
-  m <- lift multiplierp
-  sign <- lift signp
-  ambiguousRawNum <- lift rawnumberp
-  mExponent <- lift $ optional $ try exponentp
-  commodityspaced <- lift $ skipMany' spacenonewline
-  c <- lift commoditysymbolp
-  suggestedStyle <- getAmountStyle c
-
-  let rawNum = either (disambiguateNumber suggestedStyle) id ambiguousRawNum
-  (q, prec, mdec, mgrps) <- case fromRawNumber rawNum mExponent of
-    Left errMsg -> fail errMsg
-    Right res -> pure res
-
-  let s = amountstyle{ascommodityside=R, ascommodityspaced=commodityspaced, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
-  return $ Amount c (sign q) NoPrice s m
-  <?> "right-symbol amount"
-
-nosymbolamountp :: JournalParser m Amount
-nosymbolamountp = do
-  m <- lift multiplierp
-  suggestedStyle <- getDefaultAmountStyle
-  (q,prec,mdec,mgrps) <- lift $ numberp suggestedStyle
-  -- apply the most recently seen default commodity and style to this commodityless amount
-  defcs <- getDefaultCommodityAndStyle
-  let (c,s) = case defcs of
-        Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec})
-        Nothing          -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps})
-  return $ Amount c q NoPrice s m
-  <?> "no-symbol amount"
-
 commoditysymbolp :: TextParser m CommoditySymbol
 commoditysymbolp =
   quotedcommoditysymbolp <|> simplecommoditysymbolp <?> "commodity symbol"
@@ -602,23 +657,24 @@ simplecommoditysymbolp :: TextParser m CommoditySymbol
 simplecommoditysymbolp = takeWhile1P Nothing (not . isNonsimpleCommodityChar)
 
 priceamountp :: JournalParser m Price
-priceamountp = option NoPrice $ try $ do
+priceamountp = option NoPrice $ do
-  lift (skipMany spacenonewline)
   char '@'
   priceConstructor <- char '@' *> pure TotalPrice <|> pure UnitPrice
 
   lift (skipMany spacenonewline)
-  priceAmount <- amountwithoutpricep
+  priceAmount <- amountwithoutpricep <?> "amount (as a price)"
 
   pure $ priceConstructor priceAmount
 
 partialbalanceassertionp :: JournalParser m BalanceAssertion
-partialbalanceassertionp = optional $ try $ do
+partialbalanceassertionp = optional $ do
+  sourcepos <- try $ do
     lift (skipMany spacenonewline)
     sourcepos <- genericSourcePos <$> lift getPosition
     char '='
+    pure sourcepos
   lift (skipMany spacenonewline)
-  a <- amountp -- XXX should restrict to a simple amount
+  a <- amountp <?> "amount (for a balance assertion or assignment)" -- XXX should restrict to a simple amount
   return (a, sourcepos)
 
 -- balanceassertion :: Monad m => TextParser m (Maybe MixedAmount)
@@ -633,7 +689,8 @@ partialbalanceassertionp = optional $ try $ do
 
 -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
 fixedlotpricep :: JournalParser m (Maybe Amount)
-fixedlotpricep = optional $ try $ do
+fixedlotpricep = optional $ do
+  try $ do
     lift (skipMany spacenonewline)
     char '{'
   lift (skipMany spacenonewline)
@@ -657,7 +714,7 @@ fixedlotpricep = optional $ try $ do
 -- and the digit group style if any.
 --
 numberp :: Maybe AmountStyle -> TextParser m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
-numberp suggestedStyle = do
+numberp suggestedStyle = label "number" $ do
     -- a number is an optional sign followed by a sequence of digits possibly
     -- interspersed with periods, commas, or both
     -- ptrace "numberp"
@@ -669,10 +726,9 @@ numberp suggestedStyle = do
            $ fromRawNumber rawNum mExp of
       Left errMsg -> fail errMsg
       Right (q, p, d, g) -> pure (sign q, p, d, g)
-    <?> "numberp"
 
 exponentp :: TextParser m Int
-exponentp = char' 'e' *> signp <*> decimal <?> "exponentp"
+exponentp = char' 'e' *> signp <*> decimal <?> "exponent"
 
 -- | Interpret a raw number as a decimal number.
 --
@@ -706,8 +762,8 @@ fromRawNumber raw mExp = case raw of
           (quantity, precision) = toQuantity (mconcat digitGrps) decimalGrp
 
       in  Right (quantity, precision, mDecPt, Just digitGroupStyle)
-    Just _ ->
+    Just _ -> Left
-      Left "mixing digit separators with exponents is not allowed"
+      "invalid number: mixing digit separators with exponents is not allowed"
 
   where
     -- Outputs digit group sizes from least significant to most significant
@@ -764,10 +820,20 @@ disambiguateNumber suggestedStyle (AmbiguousNumber grp1 sep grp2) =
 -- Right (WithSeparators ' ' ["1","000"] Nothing)
 --
 rawnumberp :: TextParser m (Either AmbiguousNumber RawNumber)
-rawnumberp = label "rawnumberp" $ do
+rawnumberp = label "number" $ do
   rawNumber <- fmap Right leadingDecimalPt <|> leadingDigits
+
   -- Guard against mistyped numbers
-  notFollowedBy $ satisfy isDecimalPointChar <|> char ' ' *> digitChar
+  mExtraDecimalSep <- optional $ lookAhead $ satisfy isDecimalPointChar
+  when (isJust mExtraDecimalSep) $
+    fail "invalid number (invalid use of separator)"
+
+  mExtraFragment <- optional $ lookAhead $ try $
+    char ' ' *> getPosition <* digitChar
+  case mExtraFragment of
+    Just pos -> parseErrorAt pos "invalid number (excessive trailing digits)"
+    Nothing -> pure ()
+
   return $ dbg8 "rawnumberp" rawNumber
   where
 
@@ -843,7 +909,7 @@ instance Monoid DigitGrp where
   mappend = (Sem.<>)
 
 digitgroupp :: TextParser m DigitGrp
-digitgroupp = label "digit group"
+digitgroupp = label "digits"
             $ makeGroup <$> takeWhile1P (Just "digit") isDigit
   where
     makeGroup = uncurry DigitGrp . foldl' step (0, 0) . T.unpack

hledger-lib/Hledger/Read/JournalReader.hs

@@ -636,7 +636,8 @@ postingp mTransactionYear = do
     account <- modifiedaccountnamep
     return (status, account)
   let (ptype, account') = (accountNamePostingType account, textUnbracket account)
-  amount <- spaceandamountormissingp
+  lift (skipMany spacenonewline)
+  amount <- option missingmixedamt $ Mixed . (:[]) <$> amountp
   massertion <- partialbalanceassertionp
   _ <- fixedlotpricep
   lift (skipMany spacenonewline)