diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## Cassava Megaparsec 0.1.0 + +* Initial release. diff --git a/Data/Csv/Parser/Megaparsec.hs b/Data/Csv/Parser/Megaparsec.hs new file mode 100644 --- /dev/null +++ b/Data/Csv/Parser/Megaparsec.hs @@ -0,0 +1,286 @@ +-- | +-- Module : Data.Csv.Parser.Megaparsec +-- Copyright : © 2016 Stack Builders +-- License : MIT +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- A CSV parser. The parser here is RFC 4180 compliant, with the following +-- extensions: +-- +-- * Non-escaped fields may contain any characters except double-quotes, +-- commas (or generally delimiter characters), carriage returns, and +-- newlines. +-- * Escaped fields may contain any characters, but double-quotes need +-- to be escaped. +-- +-- The parser provides better error messages than the parser that comes with +-- Cassava library, while being compatible with the rest of the library. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} + +module Data.Csv.Parser.Megaparsec + ( Cec (..) + , decode + , decodeWith + , decodeByName + , decodeByNameWith ) +where + +import Control.Monad +import Data.ByteString (ByteString) +import Data.Char (chr) +import Data.Csv hiding + ( Parser + , record + , namedRecord + , header + , toNamedRecord + , decode + , decodeWith + , decodeByName + , decodeByNameWith ) +import Data.Data +import Data.Vector (Vector) +import Data.Word (Word8) +import Text.Megaparsec +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Csv as C +import qualified Data.HashMap.Strict as H +import qualified Data.Set as S +import qualified Data.Vector as V + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((*>), (<*), (<$)) + +infixl 4 <$!> + +(<$!>) :: Monad m => (a -> b) -> m a -> m b +f <$!> m = do + x <- m + let z = f x + z `seq` return z +{-# INLINE (<$!>) #-} +#endif + +---------------------------------------------------------------------------- +-- Custom error component and other types + +-- | Custom error component for CSV parsing. It allows typed reporting of +-- conversion errors. + +data Cec + = CecFail String + | CecIndentation Ordering Pos Pos + | CecConversionError String + deriving (Eq, Data, Typeable, Ord, Read, Show) + +instance ShowErrorComponent Cec where + showErrorComponent (CecFail msg) = msg + showErrorComponent (CecIndentation ord ref actual) = + "incorrect indentation (got " ++ show (unPos actual) ++ + ", should be " ++ p ++ show (unPos ref) ++ ")" + where p = case ord of + LT -> "less than " + EQ -> "equal to " + GT -> "greater than " + showErrorComponent (CecConversionError msg) = + "conversion error: " ++ msg + +instance ErrorComponent Cec where + representFail = CecFail + representIndentation = CecIndentation + +-- | Parser type that uses “custom error component” 'Cec'. + +type Parser = Parsec Cec BL.ByteString + +---------------------------------------------------------------------------- +-- Top level interface + +-- | Deserialize CSV records form a lazy 'BL.ByteString'. If this fails due +-- to incomplete or invalid input, 'Left' is returned. Equivalent to +-- 'decodeWith' 'defaultDecodeOptions'. + +decode :: FromRecord a + => HasHeader + -- ^ Whether the data contains header that should be skipped + -> FilePath + -- ^ File name (use empty string if you have none) + -> BL.ByteString + -- ^ CSV data + -> Either (ParseError Char Cec) (Vector a) +decode = decodeWith defaultDecodeOptions +{-# INLINE decode #-} + +-- | Like 'decode', but lets you customize how the CSV data is parsed. + +decodeWith :: FromRecord a + => DecodeOptions + -- ^ Decoding options + -> HasHeader + -- ^ Whether the data contains header that should be skipped + -> FilePath + -- ^ File name (use empty string if you have none) + -> BL.ByteString + -- ^ CSV data + -> Either (ParseError Char Cec) (Vector a) +decodeWith = decodeWithC csv +{-# INLINE decodeWith #-} + +-- | Deserialize CSV records from a lazy 'BL.ByteString'. If this fails due +-- to incomplete or invalid input, 'Left' is returned. The data is assumed +-- to be preceded by a header. Equivalent to 'decodeByNameWith' +-- 'defaultDecodeOptions'. + +decodeByName :: FromNamedRecord a + => FilePath -- ^ File name (use empty string if you have none) + -> BL.ByteString -- ^ CSV data + -> Either (ParseError Char Cec) (Header, Vector a) +decodeByName = decodeByNameWith defaultDecodeOptions +{-# INLINE decodeByName #-} + +-- | Like 'decodeByName', but lets you customize how the CSV data is parsed. + +decodeByNameWith :: FromNamedRecord a + => DecodeOptions -- ^ Decoding options + -> FilePath -- ^ File name (use empty string if you have none) + -> BL.ByteString -- ^ CSV data + -> Either (ParseError Char Cec) (Header, Vector a) +decodeByNameWith opts = parse (csvWithHeader opts) +{-# INLINE decodeByNameWith #-} + +-- | Decode CSV data using the provided parser, skipping a leading header if +-- necessary. + +decodeWithC + :: (DecodeOptions -> Parser a) + -- ^ Parsing function parametrized by 'DecodeOptions' + -> DecodeOptions + -- ^ Decoding options + -> HasHeader + -- ^ Whether to expect a header in the input + -> FilePath + -- ^ File name (use empty string if you have none) + -> BL.ByteString + -- ^ CSV data + -> Either (ParseError Char Cec) a +decodeWithC p opts@DecodeOptions {..} hasHeader = parse parser + where + parser = case hasHeader of + HasHeader -> header decDelimiter *> p opts + NoHeader -> p opts +{-# INLINE decodeWithC #-} + +---------------------------------------------------------------------------- +-- The parser + +-- | Parse a CSV file that does not include a header. + +csv :: FromRecord a + => DecodeOptions -- ^ Decoding options + -> Parser (Vector a) -- ^ The parser that parses collection of records +csv !DecodeOptions {..} = do + xs <- sepEndBy1 (record decDelimiter parseRecord) eol + eof + return $! V.fromList xs + +-- | Parse a CSV file that includes a header. + +csvWithHeader :: FromNamedRecord a + => DecodeOptions -- ^ Decoding options + -> Parser (Header, Vector a) + -- ^ The parser that parser collection of named records +csvWithHeader !DecodeOptions {..} = do + !hdr <- header decDelimiter + let f = parseNamedRecord . toNamedRecord hdr + xs <- sepEndBy1 (record decDelimiter f) eol + eof + return $ let !v = V.fromList xs in (hdr, v) + +-- | Parse a header, including the terminating line separator. + +header :: Word8 -> Parser Header +header del = V.fromList <$!> p <* eol + where + p = sepBy1 (name del) (blindByte del) "file header" +{-# INLINE header #-} + +-- | Parse a header name. Header names have the same format as regular +-- 'field's. + +name :: Word8 -> Parser Name +name del = field del "name in header" +{-# INLINE name #-} + +-- | Parse a record, not including the terminating line separator. The +-- terminating line separate is not included as the last record in a CSV +-- file is allowed to not have a terminating line separator. + +record + :: Word8 -- ^ Field delimiter + -> (Record -> C.Parser a) + -- ^ How to “parse” record to get the data of interest + -> Parser a +record del f = do + notFollowedBy eof -- to prevent reading empty line at the end of file + r <- V.fromList <$!> (sepBy1 (field del) (blindByte del) "a record") + case C.runParser (f r) of + Left msg -> conversionError msg + Right x -> return x +{-# INLINE record #-} + +-- | Parse a field. The field may be in either the escaped or non-escaped +-- format. The returned value is unescaped. + +field :: Word8 -> Parser Field +field del = label "a field" (escapedField <|> unescapedField del) +{-# INLINE field #-} + +-- | Parse an escaped field. + +escapedField :: Parser ByteString +escapedField = + BC8.pack <$!> between (char '"') (char '"') (many $ normalChar <|> escapedDq) + where + normalChar = noneOf "\"" "unescaped character" + escapedDq = label "escaped double-quote" ('"' <$ string "\"\"") +{-# INLINE escapedField #-} + +-- | Parse an unescaped field (up to first) + +unescapedField :: Word8 -> Parser ByteString +unescapedField del = BC8.pack <$!> many (noneOf es) -- anyChar (lookAhead $ oneOf es) + where + es = chr (fromIntegral del) : "\"\n\r" +{-# INLINE unescapedField #-} + +---------------------------------------------------------------------------- +-- Helpers + +-- | End parsing signaling a “conversion error”. + +conversionError :: String -> Parser a +conversionError msg = failure S.empty S.empty (S.singleton err) + where + err = CecConversionError msg +{-# INLINE conversionError #-} + +-- | Convert a 'Record' to a 'NamedRecord' by attaching column names. The +-- 'Header' and 'Record' must be of the same length. + +toNamedRecord :: Header -> Record -> NamedRecord +toNamedRecord hdr v = H.fromList . V.toList $ V.zip hdr v +{-# INLINE toNamedRecord #-} + +-- | Parse a byte of specified value and return unit. + +blindByte :: Word8 -> Parser () +blindByte = void . char . chr . fromIntegral +{-# INLINE blindByte #-} diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,21 @@ +# MIT License + +Copyright (c) 2016 Stack Builders + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to +deal in the Software without restriction, including without limitation the +rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,65 @@ +# Cassava Megaparsec + +[![License MIT](https://img.shields.io/badge/license-MIT-brightgreen.svg)](http://opensource.org/licenses/MIT) +[![Hackage](https://img.shields.io/hackage/v/cassava-megaparsec.svg?style=flat)](https://hackage.haskell.org/package/cassava-megaparsec) +[![Stackage Nightly](http://stackage.org/package/cassava-megaparsec/badge/nightly)](http://stackage.org/nightly/package/cassava-megaparsec) +[![Stackage LTS](http://stackage.org/package/cassava-megaparsec/badge/lts)](http://stackage.org/lts/package/cassava-megaparsec) +[![Build Status](https://travis-ci.org/stackbuilders/cassava-megaparsec.svg?branch=master)](https://travis-ci.org/stackbuilders/cassava-megaparsec) + +The package provides alternative parser for the +[Cassava](https://hackage.haskell.org/package/cassava) package written with +[Megaparsec](https://hackage.haskell.org/package/megaparsec) so you can get +better error messages at expense of some speed. + +## Quick start + +The package works seamlessly with Cassava by replacing the following +functions: + +* `decode` +* `decodeWith` +* `decodeByName` +* `decodeByNameWith` + +The functions work just the same as Cassava's equivalents, but also take +name of file they parse (to include into error messages) and return typed +high-quality error messages produced by +[Megaparsec](https://hackage.haskell.org/package/megaparsec). + +The import section typically looks like this: + +```haskell +import Data.Csv hiding (decode, decodeWith, decodeByName, decodeByNameWith) +import Data.Csv.Parser.Megaparsec (decode, decodeWith, decodeByName, decodeByNameWith) +``` + +Next you call appropriate function and get either result of parsing +identical to that of Cassava or error message. The error message is +well-typed so you can examine it in Haskell code easily. Conversion error +are considered parsing errors by the `cassava-megaparsec` package and are +reported via custom error message component `Cec` supported by Megaparsec 5. +Since Cassava's conversion errors are plain strings, we have no choice but +to represent them as strings too: + +```haskell +-- | Custom error component for CSV parsing. It allows typed reporting of +-- conversion errors. + +data Cec + = CecFail String + | CecIndentation Ordering Pos Pos + | CecConversionError String + deriving (Eq, Data, Typeable, Ord, Read, Show) +``` + +To pretty print a error message use the `parseErrorPretty` function from +`Text.Megaparsec`. + +This should be enough to start using the package, please consult Haddocks +for detailed per-function documentation. + +## License + +Copyright © 2016 Stack Builders + +Distributed under MIT license. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/cassava-megaparsec.cabal b/cassava-megaparsec.cabal new file mode 100644 --- /dev/null +++ b/cassava-megaparsec.cabal @@ -0,0 +1,80 @@ +-- +-- Cabal configuration for ‘cassava-megaparsec’ package. +-- +-- Copyright © 2016 Stack Builders +-- +-- Permission is hereby granted, free of charge, to any person obtaining a +-- copy of this software and associated documentation files (the +-- "Software"), to deal in the Software without restriction, including +-- without limitation the rights to use, copy, modify, merge, publish, +-- distribute, sublicense, and/or sell copies of the Software, and to permit +-- persons to whom the Software is furnished to do so, subject to the +-- following conditions: +-- +-- The above copyright notice and this permission notice shall be included +-- in all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN +-- NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE +-- USE OR OTHER DEALINGS IN THE SOFTWARE. + +name: cassava-megaparsec +version: 0.1.0 +cabal-version: >= 1.10 +license: MIT +license-file: LICENSE.md +author: Mark Karpov +maintainer: Mark Karpov +homepage: https://github.com/mrkkrp/cassava-megaparsec +bug-reports: https://github.com/mrkkrp/cassava-megaparsec/issues +category: Text, Web, CSV, Parsing +synopsis: Megaparsec parser of CSV files that plays nicely with Cassava +build-type: Simple +description: Megaparsec parser of CSV files that plays nicely with Cassava. +extra-source-files: CHANGELOG.md + , README.md + +source-repository head + type: git + location: https://github.com/stack-builders/cassava-megaparsec.git + +flag dev + description: Turn on development settings. + manual: True + default: False + +library + build-depends: base >= 4.7 && < 5.0 + , bytestring >= 0.9 && < 0.11 + , cassava >= 0.4.2 && < 0.5 + , containers >= 0.5 && < 0.6 + , megaparsec >= 5.0 && < 6.0 + , unordered-containers >= 0.2.7 && < 0.3 + , vector >= 0.11 && < 0.12 + exposed-modules: Data.Csv.Parser.Megaparsec + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 + +test-suite tests + main-is: Spec.hs + hs-source-dirs: tests + type: exitcode-stdio-1.0 + build-depends: base >= 4.7 && < 5.0 + , bytestring >= 0.9 && < 0.11 + , cassava >= 0.4.2 && < 0.5 + , cassava-megaparsec >= 0.1 + , hspec >= 2.0 && < 3.0 + , hspec-megaparsec >= 0.2 && < 0.3 + , vector >= 0.11 && < 0.12 + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,159 @@ +-- +-- Tests for the ‘cassava-megaparsec’ package. +-- +-- Copyright © 2016 Stack Builders +-- +-- Permission is hereby granted, free of charge, to any person obtaining a +-- copy of this software and associated documentation files (the +-- "Software"), to deal in the Software without restriction, including +-- without limitation the rights to use, copy, modify, merge, publish, +-- distribute, sublicense, and/or sell copies of the Software, and to permit +-- persons to whom the Software is furnished to do so, subject to the +-- following conditions: +-- +-- The above copyright notice and this permission notice shall be included +-- in all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN +-- NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, +-- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR +-- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE +-- USE OR OTHER DEALINGS IN THE SOFTWARE. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Data.ByteString (ByteString) +import Data.Csv hiding (decode, decodeWith, decodeByName, decodeByNameWith) +import Data.Csv.Parser.Megaparsec +import Data.Vector (Vector) +import Test.Hspec +import Test.Hspec.Megaparsec +import qualified Data.ByteString.Lazy as BL +import qualified Data.Vector as V + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "decode" decodeSpec + describe "decodeWith" decodeWithSpec + describe "decodeByName" decodeByNameSpec + describe "decodeByNameWith" decodeByNameWithSpec + +decodeSpec :: Spec +decodeSpec = do + let dec = decode NoHeader "" + it "decodes simple data" $ + dec "a,b,c\n" `shouldParse` + φ [["a", "b", "c"]] + it "decodes simple data skipping header" $ + decode HasHeader "" "field1,field2,field3\na,b,c\n" `shouldParse` + φ [["a", "b", "c"]] + it "handles CRLF sequence correctly" $ + dec "a,b\r\nc,d\r\n" `shouldParse` + φ [["a", "b"], ["c", "d"]] + it "handles missing end of line" $ + dec "a,b,c" `shouldParse` + φ [["a", "b", "c"]] + it "parses the empty line all right" $ + dec "a,b,c\n\nd,e,f\n\n" `shouldParse` + φ [["a", "b", "c"], [""], ["d", "e", "f"], [""]] + it "handles leading space" $ + dec " a, b, c\n" `shouldParse` + φ [[" a", " b", " c"]] + it "parses the RFC 4180 test data correctly" $ + dec rfc4180Input `shouldParse` + φ rfc4180Output + +decodeWithSpec :: Spec +decodeWithSpec = + context "using tab as delimiter" $ do + let dec = decodeWith defaultDecodeOptions { decDelimiter = 9 } NoHeader "" + it "works fine with tab as delimiter" $ + dec "a\tb\tc\n" `shouldParse` + φ [["a", "b", "c"]] + it "handles CRLF sequence correctly" $ + dec "a\tb\r\nc\td\r\n" `shouldParse` + φ [["a", "b"], ["c", "d"]] + it "handles missing end of line" $ + dec "a\tb\tc" `shouldParse` + φ [["a", "b", "c"]] + it "parses the empty line all right" $ + dec "a\tb\tc\n\nd\te\tf\n\n" `shouldParse` + φ [["a", "b", "c"], [""], ["d", "e", "f"], [""]] + it "handles leading space" $ + dec " a\t b\t c\n" `shouldParse` + φ [[" a", " b", " c"]] + +decodeByNameSpec :: Spec +decodeByNameSpec = do + let dec = decodeByName "" + it "decodes simple data" $ + dec "field\r\nabc\r\n" `shouldParse` + χ ["field"] [[("field", "abc")]] + it "decodes entries with two fields" $ + dec "field1,field2\r\nabc,def\r\n" `shouldParse` + χ ["field1", "field2"] [[("field1", "abc"), ("field2", "def")]] + it "decodes header ending with CRLF" $ + dec "field\r\nabc" `shouldParse` + χ ["field"] [[("field", "abc")]] + it "decodes data with training CRLF" $ + dec "field\r\nabc\r\n" `shouldParse` + χ ["field"] [[("field", "abc")]] + it "decodes multiply entries (CRLF separated)" $ + dec "field\r\nabc\r\ndef" `shouldParse` + χ ["field"] [[("field", "abc")],[("field","def")]] + +decodeByNameWithSpec :: Spec +decodeByNameWithSpec = + context "using tab as delimiter" $ do + let dec = decodeByNameWith defaultDecodeOptions { decDelimiter = 9 } "" + it "decodes simple data" $ + dec "field\r\nabc\r\n" `shouldParse` + χ ["field"] [[("field", "abc")]] + it "decodes entries with two fields" $ + dec "field1\tfield2\r\nabc\tdef\r\n" `shouldParse` + χ ["field1", "field2"] [[("field1", "abc"), ("field2", "def")]] + it "decodes header ending with CRLF" $ + dec "field\r\nabc" `shouldParse` + χ ["field"] [[("field", "abc")]] + it "decodes data with training CRLF" $ + dec "field\r\nabc\r\n" `shouldParse` + χ ["field"] [[("field", "abc")]] + it "decodes multiply entries (CRLF separated)" $ + dec "field\r\nabc\r\ndef" `shouldParse` + χ ["field"] [[("field", "abc")],[("field","def")]] + +---------------------------------------------------------------------------- +-- Helpers + +φ :: [[ByteString]] -> Vector [ByteString] +φ = V.fromList + +χ :: [ByteString] -> [[(ByteString, ByteString)]] -> (Header, Vector NamedRecord) +χ h xs = (header h, V.fromList (namedRecord <$> xs)) + +rfc4180Input :: BL.ByteString +rfc4180Input = BL.concat + [ "#field1,field2,field3\n" + , "\"aaa\",\"bb\n" + , "b\",\"ccc\"\n" + , "\"a,a\",\"b\"\"bb\",\"ccc\"\n" + , "zzz,yyy,xxx\n" ] + +rfc4180Output :: [[ByteString]] +rfc4180Output = + [ ["#field1", "field2", "field3"] + , ["aaa", "bb\nb", "ccc"] + , ["a,a", "b\"bb", "ccc"] + , ["zzz", "yyy", "xxx"] ]