diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,6 @@ + 0.3.5 + * Improve error handling (#24 #26, mgajda) + 0.3.4 * Fixed #14 and add test for #15 * Fixed typos in the examples (unhammer) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -12,4 +12,4 @@ Kevin Brubeck Unhammer ( unhammer ) - +Michal Gajda (mgajda) diff --git a/src/Xeno/Errors.hs b/src/Xeno/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Xeno/Errors.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE ViewPatterns #-} +-- | Simplifies raising and presenting localized exceptions to the user. +module Xeno.Errors(printExceptions + ,displayException + ,getStartIndex + ,failHere + ) where + +import Data.Semigroup((<>)) +import qualified Data.ByteString.Char8 as BS hiding (elem) +import Data.ByteString.Internal(ByteString(..)) +import System.IO(stderr) + +import Xeno.Types + +{-# NOINLINE failHere #-} +failHere :: BS.ByteString -> BS.ByteString -> Either XenoException a +failHere msg here = Left $ XenoParseError (getStartIndex here) msg + +-- | Print schema errors with excerpts +printExceptions :: BS.ByteString -> [XenoException] -> IO () +printExceptions i s = (BS.hPutStrLn stderr . displayException i) `mapM_` s + +-- | Find line number of the error from ByteString index. +lineNo :: Int -> BS.ByteString -> Int +lineNo index bs = BS.count '\n' + $ BS.take index bs + +-- | Show for ByteStrings +bshow :: Show a => a -> BS.ByteString +bshow = BS.pack . show + +{-# INLINE CONLIKE getStartIndex #-} +getStartIndex :: BS.ByteString -> Int +getStartIndex (PS _ from _) = from + +displayException :: BS.ByteString -> XenoException -> BS.ByteString +displayException input (XenoParseError i msg) = + "Parse error in line " <> bshow (lineNo i input) <> ": " + <> msg + <> " at:\n" + <> lineContentBeforeError + <> lineContentAfterError + <> "\n" <> pointer + where + lineContentBeforeError = snd $ BS.spanEnd eoln $ revTake 40 $ BS.take i input + lineContentAfterError = BS.takeWhile eoln $ BS.take 40 $ BS.drop i input + pointer = BS.replicate (BS.length lineContentBeforeError) ' ' <> "^" + eoln ch = ch /= '\n' && ch /= '\r' +displayException _ err = bshow err + +-- | Take n last bytes. +revTake :: Int -> BS.ByteString -> BS.ByteString +revTake i (PS ptr from to) = PS ptr (end-len) len + where + end = from + to + len = min to i + diff --git a/src/Xeno/SAX.hs b/src/Xeno/SAX.hs --- a/src/Xeno/SAX.hs +++ b/src/Xeno/SAX.hs @@ -20,7 +20,6 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Unsafe as SU import Data.Functor.Identity -import Data.Monoid import Data.Word import Xeno.Types @@ -148,7 +147,7 @@ this = S.drop index str findCommentEnd index = case elemIndexFrom commentChar str index of - Nothing -> throw (XenoParseError "Couldn't find the closing comment dash.") + Nothing -> throw $ XenoParseError index "Couldn't find the closing comment dash." Just fromDash -> if s_index this 0 == commentChar && s_index this 1 == closeTagChar then findLT (fromDash + 2) @@ -156,7 +155,7 @@ where this = S.drop index str findCDataEnd cdata_start index = case elemIndexFrom closeAngleBracketChar str index of - Nothing -> throw (XenoParseError "Couldn't find closing angle bracket for CDATA.") + Nothing -> throw $ XenoParseError index "Couldn't find closing angle bracket for CDATA." Just fromCloseAngleBracket -> if s_index str (fromCloseAngleBracket + 1) == closeAngleBracketChar then do @@ -169,7 +168,7 @@ let spaceOrCloseTag = parseName str index in if | s_index str index0 == questionChar -> case elemIndexFrom closeTagChar str spaceOrCloseTag of - Nothing -> throw (XenoParseError "Couldn't find the end of the tag.") + Nothing -> throw $ XenoParseError index "Couldn't find the end of the tag." Just fromGt -> do findLT (fromGt + 1) | s_index str spaceOrCloseTag == closeTagChar -> @@ -212,7 +211,8 @@ str (quoteIndex + 1) of Nothing -> - throw (XenoParseError "Couldn't find the matching quote character.") + throw + (XenoParseError index "Couldn't find the matching quote character.") Just endQuoteIndex -> do attrF (substring str index afterAttrName) @@ -221,8 +221,9 @@ (quoteIndex + 1) (endQuoteIndex)) findAttributes (endQuoteIndex + 1) - else throw (XenoParseError ("Expected ' or \", got: " <> S.singleton usedChar)) - else throw (XenoParseError ("Expected =, got: " <> S.singleton (s_index str afterAttrName) <> " at character index: " <> (S8.pack . show) afterAttrName)) + else throw + (XenoParseError index("Expected ' or \", got: " <> S.singleton usedChar)) + else throw (XenoParseError index ("Expected =, got: " <> S.singleton (s_index str afterAttrName) <> " at character index: " <> (S8.pack . show) afterAttrName)) where index = skipSpaces str index0 {-# INLINE process #-} @@ -249,8 +250,8 @@ -- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0. s_index :: ByteString -> Int -> Word8 s_index ps n - | n < 0 = throw XenoStringIndexProblem - | n >= S.length ps = throw XenoStringIndexProblem + | n < 0 = throw (XenoStringIndexProblem n ps) + | n >= S.length ps = throw (XenoStringIndexProblem n ps) | otherwise = ps `SU.unsafeIndex` n {-# INLINE s_index #-} diff --git a/src/Xeno/Types.hs b/src/Xeno/Types.hs --- a/src/Xeno/Types.hs +++ b/src/Xeno/Types.hs @@ -12,8 +12,10 @@ import GHC.Generics data XenoException - = XenoStringIndexProblem - | XenoParseError ByteString + = XenoStringIndexProblem { stringIndex :: Int, inputString :: ByteString } + | XenoParseError { inputIndex :: Int, message :: ByteString } | XenoExpectRootNode deriving (Show, Typeable, NFData, Generic) + instance Exception XenoException where displayException = show + diff --git a/xeno.cabal b/xeno.cabal --- a/xeno.cabal +++ b/xeno.cabal @@ -1,5 +1,5 @@ name: xeno -version: 0.3.4 +version: 0.3.5 synopsis: A fast event-based XML parser in pure Haskell description: A fast, low-memory use, event-based XML parser in pure Haskell. build-type: Simple @@ -9,8 +9,8 @@ license: BSD3 license-file: LICENSE author: Christopher Done -maintainer: Marco Zocca (zocca.marco gmail) -tested-with: GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.2 +maintainer: Marco Zocca (ocramz fripost org) +tested-with: GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.2, GHC == 8.4.4 extra-source-files: README.md CHANGELOG.markdown CONTRIBUTORS.md @@ -26,10 +26,15 @@ library hs-source-dirs: src ghc-options: -Wall -O2 - exposed-modules: Xeno.SAX, Xeno.DOM, Xeno.Types + exposed-modules: Xeno.SAX, Xeno.DOM, Xeno.Types, Xeno.Errors other-modules: Control.Spork build-depends: base >= 4.7 && < 5 - , bytestring, vector, deepseq, array, mutable-containers, mtl + , bytestring + , vector + , deepseq + , array + , mutable-containers + , mtl -- , exceptions -- | DEBUG , hspec