diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,10 @@ # Revision history for sv +## 1.0 -- 2018-07-19 +* Split the package into sv, sv-core, svfactor. This removes Data.Sv.{Parse,Print,Syntax} + and changes types in Data.Sv.Decode and Data.Sv.Encode. + Compatibility with version 0.1 is minimal + ## 0.1 -- 2018-03-06 * First version. Released on an unsuspecting world. diff --git a/src/Data/Sv.hs b/src/Data/Sv.hs --- a/src/Data/Sv.hs +++ b/src/Data/Sv.hs @@ -19,57 +19,89 @@ module Data.Sv ( -- * Decoding - decode - , parseDecode - , parseDecode' + parseDecode , parseDecodeFromFile - , parseDecodeFromFile' + , parseDecodeFromDsvCursor + , decode , decodeMay , decodeEither , decodeEither' , (>>==) , (==<<) + , module Data.Sv.Parse , module Data.Sv.Decode.Type , module Data.Sv.Decode.Error - -- * Parsing - , module Data.Sv.Parse - - -- * Printing - , module Data.Sv.Print - -- * Encoding , encode , encodeToFile , encodeToHandle , encodeBuilder , encodeRow - , encodeSv , module Data.Sv.Encode.Type , module Data.Sv.Encode.Options - -- * Core data types - , module Data.Sv.Syntax + -- * Structure + , module Data.Sv.Structure - -- * Re-exports from contravariant and semigroupoids + -- * Re-exports from contravariant, validation, and semigroupoids , Alt (..) , Contravariant (..) , Divisible (..) , divided , Decidable (..) , chosen + , Validation (..) ) where +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Attoparsec.ByteString.Lazy as AL +import Data.Bifunctor (Bifunctor (first)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.UTF8 as UTF8 +import qualified Data.ByteString.Lazy as LBS +import HaskellWorks.Data.Dsv.Lazy.Cursor as DSV import Data.Functor.Alt (Alt (..)) import Data.Functor.Contravariant (Contravariant (..)) import Data.Functor.Contravariant.Divisible (Divisible (..), divided, Decidable (..), chosen) +import Data.Validation (Validation (..)) +import Data.Sv.Alien.Cassava (field) import Data.Sv.Decode import Data.Sv.Decode.Type import Data.Sv.Decode.Error import Data.Sv.Encode import Data.Sv.Encode.Options import Data.Sv.Encode.Type +import Data.Sv.Structure import Data.Sv.Parse -import Data.Sv.Print -import Data.Sv.Syntax + +-- | Parse a 'ByteString' as an Sv, and then decode it with the given decoder. +parseDecode :: + Decode' ByteString a + -> ParseOptions + -> LBS.ByteString + -> DecodeValidation ByteString [a] +parseDecode d opts bs = + let sep = _separator opts + cursor = DSV.makeCursor sep bs + in parseDecodeFromDsvCursor d opts cursor + +-- | Load a file, parse it, and decode it. +parseDecodeFromFile :: + MonadIO m + => Decode' ByteString a + -> ParseOptions + -> FilePath + -> m (DecodeValidation ByteString [a]) +parseDecodeFromFile d opts fp = + parseDecode d opts <$> liftIO (LBS.readFile fp) + +-- | Decode from a 'DsvCursor' +parseDecodeFromDsvCursor :: Decode' ByteString a -> ParseOptions -> DsvCursor -> DecodeValidation ByteString [a] +parseDecodeFromDsvCursor d opts cursor = + let toField = Prelude.either badParse pure . parse + parse = first UTF8.fromString . AL.eitherResult . AL.parse field + in flip bindValidation (decode d) . traverse (traverse toField) . DSV.toListVector $ case _headedness opts of + Unheaded -> cursor + Headed -> nextPosition (nextRow cursor) diff --git a/src/Data/Sv/Alien/Cassava.hs b/src/Data/Sv/Alien/Cassava.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Alien/Cassava.hs @@ -0,0 +1,114 @@ +{- +Copyright (c)2012, Johan Tibell + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Johan Tibell nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +module Data.Sv.Alien.Cassava ( + field +) where + +import Data.ByteString.Builder (byteString, toLazyByteString, charUtf8) +import Data.Attoparsec.ByteString.Char8 (char) +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.Lazy as AL +import qualified Data.Attoparsec.Zepto as Z +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (toStrict) +import qualified Data.ByteString.Unsafe as BS +import GHC.Word (Word8) + +type Field = ByteString + +doubleQuote, newline, cr :: Word8 +doubleQuote = 34 +newline = 10 +cr = 13 + +-- | A strict version of 'Data.Functor.<$>' for monads. +(<$!>) :: Monad m => (a -> b) -> m a -> m b +f <$!> m = do + a <- m + return $! f a +{-# INLINE (<$!>) #-} + +infixl 4 <$!> + +-- | Parse a field. The field may be in either the escaped or +-- non-escaped format. The return value is unescaped. +field :: AL.Parser Field +field = do + _ <- A.skipWhile (== 32) -- space + mb <- A.peekWord8 + -- We purposely don't use <|> as we want to commit to the first + -- choice if we see a double quote. + case mb of + Just b | b == doubleQuote -> escapedField + _ -> unescapedField +{-# INLINE field #-} + +escapedField :: AL.Parser ByteString +escapedField = do + _ <- dquote + -- The scan state is 'True' if the previous character was a double + -- quote. We need to drop a trailing double quote left by scan. + s <- BS.init <$> A.scan False (\s c -> if c == doubleQuote + then Just (not s) + else if s then Nothing + else Just False) + if doubleQuote `BS.elem` s + then case Z.parse unescape s of + Right r -> return r + Left err -> fail err + else return s + +unescapedField :: AL.Parser ByteString +unescapedField = A.takeWhile (\ c -> c /= doubleQuote && + c /= newline && + c /= cr) + +dquote :: AL.Parser Char +dquote = char '"' + +unescape :: Z.Parser ByteString +unescape = (toStrict . toLazyByteString) <$!> go mempty where + go acc = do + h <- Z.takeWhile (/= doubleQuote) + let rest = do + start <- Z.take 2 + if (BS.unsafeHead start == doubleQuote && + BS.unsafeIndex start 1 == doubleQuote) + then go (acc `mappend` byteString h `mappend` charUtf8 '"') + else fail "invalid CSV escape sequence" + done <- Z.atEnd + if done + then return (acc `mappend` byteString h) + else rest diff --git a/src/Data/Sv/Decode.hs b/src/Data/Sv/Decode.hs --- a/src/Data/Sv/Decode.hs +++ b/src/Data/Sv/Decode.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - {-| Module : Data.Sv.Decode Copyright : (C) CSIRO 2017-2018 @@ -11,7 +7,7 @@ Portability : non-portable This module contains data structures, combinators, and primitives for -decoding an 'Sv' into a list of your Haskell datatype. +decoding a CSV into a list of your Haskell datatype. A file can be read with 'parseDecodeFromFile'. If you already have the text data in memory, it can be decoded with 'parseDecode'. @@ -33,563 +29,7 @@ -} module Data.Sv.Decode ( - -- * The types - Decode (..) -, Decode' -, Validation (..) -, DecodeValidation -, DecodeError (..) -, DecodeErrors (..) - - -- * Running Decodes -, decode -, parseDecode -, parseDecode' -, parseDecodeFromFile -, parseDecodeFromFile' - --- * Convenience constructors and functions -, decodeMay -, decodeEither -, decodeEither' -, mapErrors -, alterInput - --- * Primitive Decodes --- ** Field-based -, contents -, untrimmed -, raw -, char -, byteString -, utf8 -, lazyUtf8 -, lazyByteString -, string -, int -, integer -, float -, double -, boolean -, boolean' -, ignore -, replace -, exactly -, emptyField --- ** Row-based -, row -, rowWithSpacing - --- * Combinators -, choice -, element -, optionalField -, ignoreFailure -, orEmpty -, either -, orElse -, orElseE -, categorical -, categorical' -, (>>==) -, (==<<) -, bindDecode - --- * Building Decodes from Readable -, decodeRead -, decodeRead' -, decodeReadWithMsg - --- * Building Decodes from parsers -, withTrifecta -, withAttoparsec -, withParsec - --- * Working with errors -, onError -, decodeError -, unexpectedEndOfRow -, expectedEndOfRow -, unknownCategoricalValue -, badParse -, badDecode -, validateEither -, validateEither' -, validateMaybe -, validateMaybe' - --- * Implementation details -, runDecode -, buildDecode -, mkDecode -, mkDecodeWithQuotes -, mkDecodeWithSpaces -, promote + module Data.Sv.Decode.Core ) where -import Prelude hiding (either) -import qualified Prelude - -import Control.Lens (alaf, view) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (ReaderT (ReaderT)) -import Control.Monad.State (state) -import Data.Attoparsec.ByteString (parseOnly) -import qualified Data.Attoparsec.ByteString as A (Parser) -import Data.Bifunctor (first, second) -import Data.ByteString (ByteString) -import qualified Data.ByteString.UTF8 as UTF8 -import qualified Data.ByteString.Lazy as LBS -import Data.Char (toUpper) -import Data.Foldable (toList) -import Data.Functor.Alt (Alt (())) -import Data.Functor.Compose (Compose (Compose, getCompose)) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Monoid (First (First)) -import Data.Profunctor (lmap) -import Data.Readable (Readable (fromBS)) -import Data.Semigroup (Semigroup ((<>)), sconcat) -import Data.Semigroup.Foldable (asum1) -import Data.Set (Set, fromList, member) -import Data.String (IsString (fromString)) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8') -import qualified Data.Text.Lazy as LT -import Data.Validation (_Validation) -import Data.Vector (Vector, (!)) -import qualified Data.Vector as V -import Text.Parsec (Parsec) -import qualified Text.Parsec as P (parse) -import qualified Text.Trifecta as Tri - -import Data.Sv.Decode.Error -import Data.Sv.Decode.Type -import qualified Data.Sv.Parse as P -import Data.Sv.Parse.Options (ParseOptions) -import Data.Sv.Syntax.Field (Field (Unquoted, Quoted), fieldContents, SpacedField, Spaced (Spaced)) -import Data.Sv.Syntax.Record (Record, _fields) -import Data.Sv.Syntax.Sv (Sv, recordList) -import Text.Space (HorizontalSpace, Spaced (_value), spacedValue) - --- | Decodes a sv into a list of its values using the provided 'Decode' -decode :: Decode' s a -> Sv s -> DecodeValidation s [a] -decode f = traverse (promote f) . recordList - --- | Parse a 'ByteString' as an Sv, and then decode it with the given decoder. --- --- This version uses 'Text.Trifecta.Trifecta' to parse the 'ByteString', which is assumed to --- be UTF-8 encoded. If you want a different library, use 'parseDecode''. -parseDecode :: - Decode' ByteString a - -> ParseOptions ByteString - -> ByteString - -> DecodeValidation ByteString [a] -parseDecode = parseDecode' P.trifecta - --- | Parse text as an Sv, and then decode it with the given decoder. --- --- This version lets you choose which parsing library to use by providing an --- 'P.SvParser'. Common selections are 'P.trifecta' and 'P.attoparsecByteString'. -parseDecode' :: - P.SvParser s - -> Decode' s a - -> ParseOptions s - -> s - -> DecodeValidation s [a] -parseDecode' svp d opts s = - Prelude.either badDecode pure (P.parseSv' svp opts s) `bindValidation` decode d - --- | Load a file, parse it, and decode it. --- --- This version uses Trifecta to parse the file, which is assumed to be UTF-8 --- encoded. -parseDecodeFromFile :: - MonadIO m - => Decode' ByteString a - -> ParseOptions ByteString - -> FilePath - -> m (DecodeValidation ByteString [a]) -parseDecodeFromFile = parseDecodeFromFile' P.trifecta - --- | Load a file, parse it, and decode it. --- --- This version lets you choose which parsing library to use by providing an --- 'P.SvParser'. Common selections are 'P.trifecta' and 'P.attoparsecByteString'. -parseDecodeFromFile' :: - MonadIO m - => P.SvParser s - -> Decode' s a - -> ParseOptions s - -> FilePath - -> m (DecodeValidation s [a]) -parseDecodeFromFile' svp d opts fp = do - sv <- P.parseSvFromFile' svp opts fp - pure (Prelude.either badDecode pure sv `bindValidation` decode d) - --- | Build a 'Decode', given a function that returns 'Maybe'. --- --- Return the given error if the function returns 'Nothing'. -decodeMay :: DecodeError e -> (s -> Maybe a) -> Decode e s a -decodeMay e f = mkDecode (validateMaybe e . f) - --- | Build a 'Decode', given a function that returns 'Either'. -decodeEither :: (s -> Either (DecodeError e) a) -> Decode e s a -decodeEither f = mkDecode (validateEither . f) - --- | Build a 'Decode', given a function that returns 'Either', and a function to --- build the error. -decodeEither' :: (e -> DecodeError e') -> (s -> Either e a) -> Decode e' s a -decodeEither' e f = mkDecode (validateEither' e . f) - --- | Succeeds with the whole field structure, including spacing and quoting information -raw :: Decode e s (SpacedField s) -raw = mkDecodeWithSpaces pure - --- | Returns the field contents. This keeps the spacing around an unquoted field. -untrimmed :: Monoid s => (HorizontalSpace -> s) -> Decode e s s -untrimmed fromSpace = - let sp = foldMap fromSpace - spaceIfNecessary (Spaced b a f) = case f of - Unquoted s -> mconcat [sp b, s, sp a] - Quoted _ _ -> view fieldContents f - in fmap spaceIfNecessary raw - --- | Get the contents of a field without doing any decoding. This never fails. -contents :: Decode e s s -contents = mkDecode pure - --- | Grab the whole row as a 'Vector' -row :: Decode e s (Vector s) -row = (fmap . fmap) (view (spacedValue.fieldContents)) rowWithSpacing - --- | Grab the whole row, including all spacing and quoting information, --- as a 'Vector' -rowWithSpacing :: Decode e s (Vector (SpacedField s)) -rowWithSpacing = - Decode . Compose . DecodeState . ReaderT $ \v -> - state (const (pure v, Ind (V.length v))) - --- | Get a field that's a single char. This will fail if there are mulitple --- characters in the field. -char :: Decode' ByteString Char -char = string >>== \cs -> case cs of - [] -> badDecode "Expected single char but got empty string" - (c:[]) -> pure c - (_:_:_) -> badDecode ("Expected single char but got " <> UTF8.fromString cs) - --- | Get the contents of a field as a bytestring. --- --- Alias for 'contents' -byteString :: Decode' ByteString ByteString -byteString = contents - --- | Get the contents of a UTF-8 encoded field as 'Text' --- --- This will also work for ASCII text, as ASCII is a subset of UTF-8 -utf8 :: Decode' ByteString Text -utf8 = contents >>== - Prelude.either (badDecode . UTF8.fromString . show) pure . decodeUtf8' - --- | Get the contents of a field as a lazy 'Data.Text.Lazy.Text' -lazyUtf8 :: Decode' ByteString LT.Text -lazyUtf8 = LT.fromStrict <$> utf8 - --- | Get the contents of a field as a lazy 'Data.ByteString.Lazy.ByteString' -lazyByteString :: Decode' ByteString LBS.ByteString -lazyByteString = LBS.fromStrict <$> contents - --- | Get the contents of a field as a 'String' -string :: Decode' ByteString String -string = UTF8.toString <$> contents - --- | Throw away the contents of a field. This is useful for skipping unneeded fields. -ignore :: Decode e s () -ignore = replace () - --- | Throw away the contents of a field, and return the given value. -replace :: a -> Decode e s a -replace a = a <$ contents - --- | Decode exactly the given string, or else fail. -exactly :: (Semigroup s, Eq s, IsString s) => s -> Decode' s s -exactly s = contents >>== \z -> - if s == z - then pure s - else badDecode (sconcat ("'":|[z,"' was not equal to '",s,"'"])) - --- | Decode a UTF-8 'ByteString' field as an 'Int' -int :: Decode' ByteString Int -int = named "int" - --- | Decode a UTF-8 'ByteString' field as an 'Integer' -integer :: Decode' ByteString Integer -integer = named "integer" - --- | Decode a UTF-8 'ByteString' field as a 'Float' -float :: Decode' ByteString Float -float = named "float" - --- | Decode a UTF-8 'ByteString' field as a 'Double' -double :: Decode' ByteString Double -double = named "double" - --- | Decode a field as a 'Bool' --- --- This aims to be tolerant to different forms a boolean might take. -boolean :: (IsString s, Ord s) => Decode' s Bool -boolean = boolean' fromString - --- | Decode a field as a 'Bool'. This version lets you provide the fromString --- function that's right for you, since 'Data.String.IsString' on a --- 'Data.ByteString.ByteString' will do the wrong thing in the case of many --- encodings such as UTF-16 or UTF-32. --- --- This aims to be tolerant to different forms a boolean might take. -boolean' :: Ord s => (String -> s) -> Decode' s Bool -boolean' s = - categorical' [ - (False, fmap s ["false", "False", "FALSE", "f", "F", "0", "n", "N", "no", "No", "NO", "off", "Off", "OFF"]) - , (True, fmap s ["true", "True", "TRUE", "t", "T", "1", "y", "Y", "yes", "Yes", "YES", "on", "On", "ON"]) - ] - --- | Succeed only when the given field is the empty string. --- --- The empty string surrounded in quotes or spaces is still the empty string. -emptyField :: (Eq s, IsString s, Semigroup s) => Decode' s () -emptyField = contents >>== \c -> - if c == fromString "" then - pure () - else - badDecode ("Expected emptiness but got: " <> c) - --- | Choose the leftmost 'Decode' that succeeds. Alias for '' -choice :: Decode e s a -> Decode e s a -> Decode e s a -choice = () - --- | Choose the leftmost 'Decode' that succeeds. Alias for 'asum1' -element :: NonEmpty (Decode e s a) -> Decode e s a -element = asum1 - --- | Try the given 'Decode'. If it fails, instead succeed with 'Nothing'. -ignoreFailure :: Decode e s a -> Decode e s (Maybe a) -ignoreFailure a = Just <$> a Nothing <$ ignore - --- | If the field is the empty string, succeed with 'Nothing'. --- Otherwise try the given 'Decode'. -orEmpty :: (Eq s, IsString s, Semigroup s) => Decode' s a -> Decode' s (Maybe a) -orEmpty a = Nothing <$ emptyField Just <$> a - --- | Try the given 'Decode'. If it fails, succeed without consuming anything. --- --- This usually isn't what you want. 'ignoreFailure' and 'orEmpty' are more --- likely what you are after. -optionalField :: Decode e s a -> Decode e s (Maybe a) -optionalField a = Just <$> a pure Nothing - --- | Try the first, then try the second, and wrap the winner in an 'Either'. --- --- This is left-biased, meaning if they both succeed, left wins. -either :: Decode e s a -> Decode e s b -> Decode e s (Either a b) -either a b = fmap Left a fmap Right b - --- | Try the given decoder, otherwise succeed with the given value. -orElse :: Decode e s a -> a -> Decode e s a -orElse f a = f replace a - --- | Try the given decoder, or if it fails succeed with the given value, in an 'Either'. -orElseE :: Decode e s b -> a -> Decode e s (Either a b) -orElseE b a = fmap Right b replace (Left a) - --- | Decode categorical data, given a list of the values and the strings which match them. --- --- Usually this is used with sum types with nullary constructors. --- --- > data TrafficLight = Red | Amber | Green --- > categorical [(Red, "red"), (Amber, "amber"), (Green, "green")] -categorical :: (Ord s, Show a) => [(a, s)] -> Decode' s a -categorical = categorical' . fmap (fmap pure) - --- | Decode categorical data, given a list of the values and lists of strings --- which match them. --- --- This version allows for multiple strings to match each value, which is --- useful for when the categories are inconsistently labelled. --- --- > data TrafficLight = Red | Amber | Green --- > categorical' [(Red, ["red", "R"]), (Amber, ["amber", "orange", "A"]), (Green, ["green", "G"])] --- --- For another example of its usage, see the source for 'boolean'. -categorical' :: forall s a . (Ord s, Show a) => [(a, [s])] -> Decode' s a -categorical' as = - let as' :: [(a, Set s)] - as' = fmap (second fromList) as - go :: s -> (a, Set s) -> Maybe a - go s (a, set) = - if s `member` set - then Just a - else Nothing - in contents >>== \s -> - validateMaybe (UnknownCategoricalValue s (fmap snd as)) $ - alaf First foldMap (go s) as' - --- | Use the 'Readable' instance to try to decode the given value. -decodeRead :: Readable a => Decode' ByteString a -decodeRead = decodeReadWithMsg (mappend "Couldn't parse ") - --- | Use the 'Readable' instance to try to decode the given value, --- or fail with the given error message. -decodeRead' :: Readable a => ByteString -> Decode' ByteString a -decodeRead' e = decodeReadWithMsg (const e) - --- | Use the 'Readable' instance to try to decode the given value, --- or use the value to build an error message. -decodeReadWithMsg :: Readable a => (ByteString -> e) -> Decode e ByteString a -decodeReadWithMsg e = contents >>== \c -> - maybe (badDecode (e c)) pure . fromBS $ c - --- | Given the name of a type, try to decode it using 'Readable', -named :: Readable a => ByteString -> Decode' ByteString a -named name = - let vs' = ['a','e','i','o','u'] - vs = fmap toUpper vs' ++ vs' - n c = if c `elem` vs then "n" else "" - n' = foldMap (n . fst) . UTF8.uncons - n'' = n' name - space = " " - in decodeReadWithMsg $ \bs -> - mconcat ["Couldn't parse \"", bs, "\" as a", n'', space, name] - --- | Map over the errors of a 'Decode' --- --- To map over the other two parameters, use the 'Data.Profunctor.Profunctor' instance. -mapErrors :: (e -> x) -> Decode e s a -> Decode x s a -mapErrors f (Decode (Compose r)) = Decode (Compose (fmap (first (fmap f)) r)) - --- | This transforms a @Decode' s a@ into a @Decode' t a@. It needs --- functions in both directions because the errors can include fragments of the --- input. --- --- @alterInput :: (s -> t) -> (t -> s) -> Decode' s a -> Decode' t a@ -alterInput :: (e -> x) -> (t -> s) -> Decode e s a -> Decode x t a -alterInput f g = mapErrors f . lmap g - ----- Promoting parsers to 'Decode's - --- | Build a 'Decode' from a Trifecta parser -withTrifecta :: Tri.Parser a -> Decode' ByteString a -withTrifecta = - mkParserFunction - (validateTrifectaResult (BadDecode . UTF8.fromString)) - (flip Tri.parseByteString mempty) - --- | Build a 'Decode' from an Attoparsec parser -withAttoparsec :: A.Parser a -> Decode' ByteString a -withAttoparsec = - mkParserFunction - (validateEither' (BadDecode . fromString)) - parseOnly - --- | Build a 'Decode' from a Parsec parser -withParsec :: Parsec ByteString () a -> Decode' ByteString a -withParsec = - -- Parsec will include a position, but it will only confuse the user - -- since it won't correspond obviously to a position in their source file. - let dropPos = drop 1 . dropWhile (/= ':') - in mkParserFunction - (validateEither' (BadDecode . UTF8.fromString . dropPos . show)) - (\p s -> P.parse p mempty s) - -mkParserFunction :: - Tri.CharParsing p - => (f a -> DecodeValidation ByteString a) - -> (p a -> ByteString -> f a) - -> p a - -> Decode' ByteString a -mkParserFunction err run p = - let p' = p <* Tri.eof - in byteString >>== (err . run p') -{-# INLINE mkParserFunction #-} - --- | Convenience to get the underlying function out of a Decode in a useful form -runDecode :: Decode e s a -> Vector (SpacedField s) -> Ind -> (DecodeValidation e a, Ind) -runDecode = runDecodeState . getCompose . unwrapDecode -{-# INLINE runDecode #-} - --- | This can be used to build a 'Decode' whose value depends on the --- result of another 'Decode'. This is especially useful since 'Decode' is not --- a 'Monad'. --- --- If you need something like this but with more power, look at 'bindDecode' -(>>==) :: Decode e s a -> (a -> DecodeValidation e b) -> Decode e s b -(>>==) = flip (==<<) -infixl 1 >>== -{-# INLINE (>>==) #-} - --- | flipped '>>==' -(==<<) :: (a -> DecodeValidation e b) -> Decode e s a -> Decode e s b -(==<<) f (Decode c) = - Decode (rmapC (`bindValidation` (view _Validation . f)) c) - where - rmapC g (Compose fga) = Compose (fmap g fga) -infixr 1 ==<< - --- | Bind through a 'Decode'. --- --- This bind does not agree with the 'Applicative' instance because it does --- not accumulate multiple error values. This is a violation of the 'Monad' --- laws, meaning 'Decode' is not a 'Monad'. --- --- That is not to say that there is anything wrong with using this function. --- It can be quite useful. -bindDecode :: Decode e s a -> (a -> Decode e s b) -> Decode e s b -bindDecode d f = - buildDecode $ \v i -> - case runDecode d v i of - (Failure e, i') -> (Failure e, i') - (Success a, i') -> runDecode (f a) v i' - --- | Run a 'Decode', and based on its errors build a new 'Decode'. -onError :: Decode e s a -> (DecodeErrors e -> Decode e s a) -> Decode e s a -onError d f = - buildDecode $ \v i -> - case runDecode d v i of - (Failure e, i') -> runDecode (f e) v i' - (Success a, i') -> (Success a, i') - --- | Build a 'Decode' from a function. --- --- This version gives you just the contents of the field, with no information --- about the spacing or quoting around that field. -mkDecode :: (s -> DecodeValidation e a) -> Decode e s a -mkDecode f = mkDecodeWithQuotes (f . view fieldContents) - --- | Build a 'Decode' from a function. --- --- This version gives you access to the whole 'Field', which includes --- information about whether quotes were used, and if so which ones. -mkDecodeWithQuotes :: (Field s -> DecodeValidation e a) -> Decode e s a -mkDecodeWithQuotes f = mkDecodeWithSpaces (f . _value) - --- | Build a 'Decode' from a function. --- --- This version gives you access to the whole 'SpacedField', which includes --- information about spacing both before and after the field, and about quotes --- if they were used. -mkDecodeWithSpaces :: (SpacedField s -> DecodeValidation e a) -> Decode e s a -mkDecodeWithSpaces f = - Decode . Compose . DecodeState . ReaderT $ \v -> state $ \(Ind i) -> - if i >= length v - then (unexpectedEndOfRow, Ind i) - else (f (v ! i), Ind (i+1)) - --- | promotes a Decode to work on a whole 'Record' at once. This does not need --- to be called by the user. Instead use 'decode'. -promote :: Decode' s a -> Record s -> DecodeValidation s a -promote dec rs = - let vec = V.fromList . toList . _fields $ rs - len = length vec - in case runDecode dec vec (Ind 0) of - (d, Ind i) -> - if i >= len - then d - else d *> expectedEndOfRow (V.force (V.drop i vec)) +import Data.Sv.Decode.Core diff --git a/src/Data/Sv/Decode/Error.hs b/src/Data/Sv/Decode/Error.hs deleted file mode 100644 --- a/src/Data/Sv/Decode/Error.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-| -Module : Data.Sv.Decode.Error -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable --} - -module Data.Sv.Decode.Error ( - DecodeError (..) -, DecodeErrors (..) - --- * Convenience constructors -, decodeError -, unexpectedEndOfRow -, expectedEndOfRow -, unknownCategoricalValue -, badParse -, badDecode - --- * Conversions -, validateEither -, validateEither' -, validateMaybe -, validateMaybe' -, trifectaResultToEither -, validateTrifectaResult - --- * Re-exports from @validation@ -, bindValidation -) where - -import Data.Validation (Validation (Failure), bindValidation) -import Data.Vector (Vector) -import qualified Text.Trifecta as Trifecta (Result (Success, Failure), _errDoc) - -import Data.Sv.Decode.Type -import Data.Sv.Syntax.Field - --- | Build a failing 'DecodeValidation' -decodeError :: DecodeError e -> DecodeValidation e a -decodeError = Failure . DecodeErrors . pure - --- | Fail with 'UnexpectedEndOfRow' -unexpectedEndOfRow :: DecodeValidation e a -unexpectedEndOfRow = decodeError UnexpectedEndOfRow - --- | Fail with 'ExpectedEndOfRow'. This takes the rest of the row, so that it --- can be displayed to the user. -expectedEndOfRow :: Vector (SpacedField e) -> DecodeValidation e a -expectedEndOfRow = decodeError . ExpectedEndOfRow - --- | Fail with 'UnknownCategoricalValue'. --- It takes the unknown value and the list of good categorical values. --- --- This mostly exists to be used by the 'Data.Sv.Decode.categorical' function. -unknownCategoricalValue :: e -> [[e]] -> DecodeValidation e a -unknownCategoricalValue unknown valids = - decodeError (UnknownCategoricalValue unknown valids) - --- | Fail with 'BadParse' with the given message. This is for when the parse --- step fails, and decoding does not even begin. -badParse :: e -> DecodeValidation e a -badParse = decodeError . BadParse - --- | Fail with 'BadDecode' with the given message. This is something of a --- generic error for when decoding a field goes wrong. -badDecode :: e -> DecodeValidation e a -badDecode = decodeError . BadDecode - --- | Build a 'DecodeValidation' from an 'Either' -validateEither :: Either (DecodeError e) a -> DecodeValidation e a -validateEither = validateEither' id - --- | Build a 'DecodeValidation' from an 'Either', given a function to build the error. -validateEither' :: (e -> DecodeError e') -> Either e a -> DecodeValidation e' a -validateEither' f = either (decodeError . f) pure - --- | Build a 'DecodeValidation' from a 'Maybe'. You have to supply an error --- to use in the 'Nothing' case -validateMaybe :: DecodeError e -> Maybe b -> DecodeValidation e b -validateMaybe e = maybe (decodeError e) pure - --- | Build a 'DecodeValidation' from a function that returns a 'Maybe' --- You have to supply an error to use in the 'Nothing' case -validateMaybe' :: (a -> Maybe b) -> DecodeError e -> a -> DecodeValidation e b -validateMaybe' ab e a = validateMaybe e (ab a) - --- | Helper to convert "Text.Trifecta" 'Text.Trifecta.Result' to 'Either'. -trifectaResultToEither :: Trifecta.Result a -> Either String a -trifectaResultToEither result = case result of - Trifecta.Success a -> Right a - Trifecta.Failure e -> Left . show . Trifecta._errDoc $ e - --- | Convert a "Text.Trifecta" 'Text.Trifecta.Result' to a 'DecodeValidation' -validateTrifectaResult :: (String -> DecodeError e) -> Trifecta.Result a -> DecodeValidation e a -validateTrifectaResult f = validateEither' f . trifectaResultToEither - diff --git a/src/Data/Sv/Decode/Type.hs b/src/Data/Sv/Decode/Type.hs deleted file mode 100644 --- a/src/Data/Sv/Decode/Type.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TupleSections #-} - -{-| -Module : Data.Sv.Decode.Type -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable --} - -module Data.Sv.Decode.Type ( - Decode (..) -, Decode' -, buildDecode -, DecodeState (..) -, runDecodeState -, Ind (..) -, DecodeError (..) -, DecodeErrors (..) -, DecodeValidation -, Validation (..) -) where - -import Control.DeepSeq (NFData) -import Control.Monad.Reader (ReaderT (ReaderT, runReaderT), MonadReader, withReaderT) -import Control.Monad.State (State, runState, state, MonadState) -import Data.Functor.Alt (Alt (())) -import Data.Functor.Apply (Apply) -import Data.Functor.Bind (Bind ((>>-))) -import Data.Functor.Compose (Compose (Compose)) -import Data.List.NonEmpty -import Data.Semigroup -import Data.Profunctor (Profunctor (lmap, rmap)) -import Data.Validation (Validation (Success, Failure)) -import Data.Vector (Vector) -import GHC.Generics (Generic) - -import Data.Sv.Syntax.Field (SpacedField) - --- | A 'Decode e s a' is for decoding some fields from a CSV row into our type 'a'. --- --- The second type parameter (@s@) is the input string type --- (usually 'ByteString' or 'Text'). --- The first type parameter (@e@) is the type of strings which occur in errors. --- Under most circumstances you want these type paraters to coincide, but they --- don't have to. They are two separate type parameters instead of one so that --- 'Decode' can have a 'Data.Profunctor.Profunctor' instance. --- --- There are primitive 'Decode's, and combinators for composing or --- otherwise manipulating them. In particular, 'Decode' is an --- 'Applicative' functor and an 'Alt' from the semigroupoids package. --- --- 'Decode' is not a 'Monad', but we can perform monad-like operations on --- it with 'Data.Sv.Decode.Field.>>==' and 'Data.Sv.Decode.bindDecode' -newtype Decode e s a = - Decode { unwrapDecode :: Compose (DecodeState s) (DecodeValidation e) a } - deriving (Functor, Apply, Applicative) - --- | 'Decode'' is 'Decode' with the input and error types the same. You usually --- want them to be the same, and most primitives are set up this way. -type Decode' s = Decode s s - -instance Alt (Decode e s) where - Decode (Compose as) Decode (Compose bs) = - buildDecode $ \v i -> - case runDecodeState as v i of - (a, j) -> case runDecodeState bs v i of - (b, k) -> - let a' = fmap (,j) a - b' = fmap (,k) b - in case a' b' of - Failure e -> (Failure e, k) - Success (z, m) -> (Success z, m) - -instance Profunctor (Decode e) where - lmap f (Decode (Compose dec)) = Decode (Compose (lmap f dec)) - rmap = fmap - --- | As we decode a row of data, we walk through its 'Data.Sv.Syntax.Field's. This 'Monad' --- keeps track of our remaining 'Data.Sv.Syntax.Field's. -newtype DecodeState s a = - DecodeState { getDecodeState :: ReaderT (Vector (SpacedField s)) (State Ind) a } - deriving (Functor, Apply, Applicative, Monad, MonadReader (Vector (SpacedField s)), MonadState Ind) - -instance Bind (DecodeState s) where - (>>-) = (>>=) - -instance Profunctor DecodeState where - lmap f (DecodeState s) = DecodeState (withReaderT (fmap (fmap (fmap f))) s) - rmap = fmap - --- | Convenient constructor for 'Decode' that handles all the newtype noise for you. -buildDecode :: (Vector (SpacedField s) -> Ind -> (DecodeValidation e a, Ind)) -> Decode e s a -buildDecode f = Decode . Compose . DecodeState . ReaderT $ \v -> state $ \i -> f v i - --- | Convenient function to run a DecodeState -runDecodeState :: DecodeState s a -> Vector (SpacedField s) -> Ind -> (a, Ind) -runDecodeState = fmap runState . runReaderT . getDecodeState - --- | Newtype for indices into the field vector -newtype Ind = Ind Int - --- | 'DecodeError' is a value indicating what went wrong during a parse or --- decode. Its constructor indictates the type of error which occured, and --- there is usually an associated string with more finely-grained details. -data DecodeError e = - -- | I was looking for another field, but I am at the end of the row - UnexpectedEndOfRow - -- | I should be at the end of the row, but I found extra fields - | ExpectedEndOfRow (Vector (SpacedField e)) - -- | This decoder was built using the 'categorical' primitive for categorical data - | UnknownCategoricalValue e [[e]] - -- | The parser failed, meaning decoding proper didn't even begin - | BadParse e - -- | Some other kind of decoding failure occured - | BadDecode e - deriving (Eq, Ord, Show, Generic) - -instance Functor DecodeError where - fmap f d = case d of - UnexpectedEndOfRow -> UnexpectedEndOfRow - ExpectedEndOfRow v -> ExpectedEndOfRow (fmap (fmap (fmap f)) v) - UnknownCategoricalValue e ess -> UnknownCategoricalValue (f e) (fmap (fmap f) ess) - BadParse e -> BadParse (f e) - BadDecode e -> BadDecode (f e) - -instance NFData e => NFData (DecodeError e) - --- | 'DecodeErrors' is a 'Semigroup' full of 'DecodeError'. It is used as the --- error side of a 'DecodeValidation'. When multiple errors occur, they will --- be collected. -newtype DecodeErrors e = - DecodeErrors (NonEmpty (DecodeError e)) - deriving (Eq, Ord, Show, Semigroup, Generic) - -instance Functor DecodeErrors where - fmap f (DecodeErrors nel) = DecodeErrors (fmap (fmap f) nel) - -instance NFData e => NFData (DecodeErrors e) - --- | 'DecodeValidation' is the error-accumulating 'Applicative' underlying --- 'Decode' -type DecodeValidation e = Validation (DecodeErrors e) diff --git a/src/Data/Sv/Encode.hs b/src/Data/Sv/Encode.hs --- a/src/Data/Sv/Encode.hs +++ b/src/Data/Sv/Encode.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} - {-| Module : Data.Sv.Encode Copyright : (C) CSIRO 2017-2018 @@ -8,428 +5,10 @@ Maintainer : George Wilson Stability : experimental Portability : non-portable - -This module is intended to be imported qualified as follows - -@import Data.Sv.Encode as E@ - -To produce a CSV file from data types, build an 'Encode' for your data -type. This module contains primitives, combinators, and type class instances -to help you to do so. - -'Encode' is a 'Contravariant' functor, as well as a 'Divisible' and -'Decidable'. 'Divisible' is the contravariant form of 'Applicative', -while 'Decidable' is the contravariant form of 'Control.Applicative.Alternative'. -These type classes will provide useful combinators for working with 'Encode's. - -Specialised to 'Encode', the function 'Data.Functor.Contravariant.Divisible.divide' -from 'Divisible' has the type: - -@ -divide :: (a -> (b,c)) -> Encode b -> Encode c -> Encode a -@ - -which can be read "if 'a' can be split into 'b' and 'c', and I can handle -'b', and I can handle 'c', then I can handle 'a'". - -Here the "I can handle" -part corresponds to the 'Encode'. If we think of (covariant) functors as -being "full of" 'a', then we can think of contravariant functors as being -"able to handle" 'a'. - -How does it work? Perform the split on the 'a', handle the 'b' by converting -it into some text, -handle the 'c' by also converting it to some text, then put each of those -text fragments into their own field in the CSV. - -Similarly, the function 'Data.Functor.Contravariant.Divisible.choose' -from 'Decidable', specialsed to 'Encode', has the type: - -@ -choose :: (a -> Either b c) -> Encode b -> Encode c -> Encode a -@ - -which can be read "if 'a' is either 'b' or 'c', and I can handle 'b', -and I can handle 'c', then I can handle 'a'". - -This works by performing the split, then checking whether 'b' or 'c' resulted, -then using the appropriate 'Encode'. - -For an example of encoding, see - -} module Data.Sv.Encode ( - Encode (..) - --- * Convenience constructors -, mkEncodeBS -, mkEncodeWithOpts -, unsafeBuilder - --- * Running an Encode -, encode -, encodeToHandle -, encodeToFile -, encodeBuilder -, encodeRow -, encodeRowBuilder -, encodeSv - --- * Options -, module Data.Sv.Encode.Options - --- * Primitive encodes --- ** Field-based -, const -, show -, nop -, empty -, orEmpty -, char -, int -, integer -, float -, double -, boolTrueFalse -, booltruefalse -, boolyesno -, boolYesNo -, boolYN -, bool10 -, string -, text -, byteString -, lazyByteString --- ** Row-based -, row - --- * Combinators -, (?>) -, (>) -, (<), (<**>)) -import Control.Lens (Getting, preview, review, view) -import Control.Monad (join) -import qualified Data.Bool as B (bool) -import qualified Data.ByteString as Strict -import qualified Data.ByteString.Builder as BS -import qualified Data.ByteString.Lazy as LBS -import Data.Foldable (fold, foldMap, toList) -import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Functor.Contravariant.Divisible (Divisible (conquer), Decidable (choose)) -import Data.List.NonEmpty (NonEmpty, nonEmpty) -import Data.Monoid (Monoid (mempty), First, (<>), mconcat) -import Data.Sequence (Seq, ViewL (EmptyL, (:<)), viewl, (<|)) -import qualified Data.Sequence as Seq -import qualified Data.Sequence as S (singleton, empty) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import System.IO (BufferMode (BlockBuffering), Handle, hClose, hSetBinaryMode, hSetBuffering, openFile, IOMode (WriteMode)) - -import Data.Sv.Encode.Options (EncodeOptions (..), HasEncodeOptions (..), HasSeparator (..), defaultEncodeOptions) -import Data.Sv.Encode.Type (Encode (Encode, getEncode)) -import Data.Sv.Syntax.Field (Field (Unquoted), SpacedField, unescapedField) -import Data.Sv.Syntax.Record (Record (Record), Records (EmptyRecords), emptyRecord, mkRecords, recordNel) -import Data.Sv.Syntax.Sv (Sv (Sv), Header (Header)) -import qualified Data.Vector.NonEmpty as V -import Text.Escape (Escaper, Escaper', Unescaped (Unescaped), escapeChar, escapeString, escapeText, escapeUtf8, escapeUtf8Lazy) -import Text.Newline (newlineToString) -import Text.Space (Spaced (Spaced), spacesString) -import Text.Quote (quoteChar) - --- | Make an 'Encode' from a function that builds one 'Field'. -mkEncodeBS :: (a -> LBS.ByteString) -> Encode a -mkEncodeBS = unsafeBuilder . fmap BS.lazyByteString - --- | Make an 'Encode' from a function that builds one 'Field'. -mkEncodeWithOpts :: (EncodeOptions -> a -> BS.Builder) -> Encode a -mkEncodeWithOpts = Encode . fmap (fmap pure) - --- | Make an encode from any function that returns a ByteString 'Builder'. -unsafeBuilder :: (a -> BS.Builder) -> Encode a -unsafeBuilder b = Encode (\_ a -> pure (b a)) -{-# INLINE unsafeBuilder #-} - --- | Encode the given list with the given 'Encode', configured by the given --- 'EncodeOptions'. -encode :: Encode a -> EncodeOptions -> [a] -> LBS.ByteString -encode enc opts = BS.toLazyByteString . encodeBuilder enc opts - --- | Encode, writing the output to a file handle. -encodeToHandle :: Encode a -> EncodeOptions -> [a] -> Handle -> IO () -encodeToHandle enc opts as h = - BS.hPutBuilder h (encodeBuilder enc opts as) - --- | Encode, writing to a file. This is way is more efficient than encoding to --- a 'ByteString' and then writing to file. -encodeToFile :: Encode a -> EncodeOptions -> [a] -> FilePath -> IO () -encodeToFile enc opts as fp = do - h <- openFile fp WriteMode - hSetBuffering h (BlockBuffering Nothing) - hSetBinaryMode h True - encodeToHandle enc opts as h - hClose h - --- | Encode to a ByteString 'Builder', which is useful if you are going --- to combine the output with other 'ByteString's. -encodeBuilder :: Encode a -> EncodeOptions -> [a] -> BS.Builder -encodeBuilder e opts as = - let enc = encodeRowBuilder e opts - nl = newlineToString (_newline opts) - terminal = if _terminalNewline opts then nl else mempty - in case as of - [] -> terminal - (a:as') -> enc a <> mconcat [nl <> enc a' | a' <- as'] <> terminal - --- | Encode one row only -encodeRow :: Encode a -> EncodeOptions -> a -> LBS.ByteString -encodeRow e opts = BS.toLazyByteString . encodeRowBuilder e opts - --- | Encode one row only, as a ByteString 'Builder' -encodeRowBuilder :: Encode a -> EncodeOptions -> a -> BS.Builder -encodeRowBuilder e opts = - let addSeparators = intersperseSeq (BS.charUtf8 (view separator opts)) - quotep = foldMap (BS.charUtf8 . review quoteChar) (view quote opts) - addQuotes x = quotep <> x <> quotep - mkSpaces optic = BS.stringUtf8 . review spacesString . view optic $ opts - bspaces = mkSpaces spacingBefore - aspaces = mkSpaces spacingAfter - addSpaces x = bspaces <> x <> aspaces - in fold . addSeparators . fmap (addSpaces . addQuotes) . getEncode e opts - --- | Build an 'Sv' rather than going straight to 'ByteString'. This allows you --- to query the Sv or run sanity checks. -encodeSv :: Encode a -> EncodeOptions -> Maybe (NonEmpty Strict.ByteString) -> [a] -> Sv Strict.ByteString -encodeSv e opts headerStrings as = - let encoded :: [Seq BS.Builder] - encoded = getEncode e opts <$> as - nl = view newline opts - sep = view separator opts - mkSpaced = Spaced (_spacingBefore opts) (_spacingAfter opts) - mkField = maybe Unquoted unescapedField (_quote opts) - mkHeader r = Header r nl - mkRecord :: NonEmpty z -> Record z - mkRecord = recordNel . fmap (mkSpaced . mkField) - header :: Maybe (Header Strict.ByteString) - header = mkHeader . mkRecord <$> headerStrings - rs :: Records Strict.ByteString - rs = l2rs (b2r <$> encoded) - l2rs = maybe EmptyRecords (mkRecords nl) . nonEmpty -- Records . fmap (skrinple nl) . nonEmpty - terminal = if _terminalNewline opts then [nl] else [] - b2f :: BS.Builder -> SpacedField Strict.ByteString - b2f = mkSpaced . mkField . LBS.toStrict . BS.toLazyByteString - b2r :: Seq BS.Builder -> Record Strict.ByteString - b2r = maybe emptyRecord (Record . V.fromNel) . nonEmpty . toList . fmap b2f - in Sv sep header rs terminal - --- | Encode this 'Data.ByteString.ByteString' every time, ignoring the input. -const :: Strict.ByteString -> Encode a -const b = contramap (pure b) byteString - --- | Build an 'Encode' using a type's 'Show' instance. -show :: Show a => Encode a -show = contramap P.show string - --- | Don't encode anything. -nop :: Encode a -nop = conquer - --- | Encode anything as the empty string. -empty :: Encode a -empty = Encode (pure (pure (pure mempty))) - --- | Lift an Encode to be able to hanlde 'Maybe', by using the empty string --- in the case of 'Nothing' -orEmpty :: Encode a -> Encode (Maybe a) -orEmpty = choose (maybe (Left ()) Right) empty - --- | Build an 'Encode' for 'Maybe' given a 'Just' and a 'Nothing' encode. -(?>) :: Encode a -> Encode () -> Encode (Maybe a) -(?>) = flip () #-} - --- | Build an 'Encode' for 'Maybe' given a 'Nothing' and a 'Just' encode. -( Encode a -> Encode (Maybe a) -(>) :: Encode a -> Strict.ByteString -> Encode (Maybe a) -(?>>) a s = a ?> const s -{-# INLINE (?>>) #-} - --- | Build an 'Encode' for 'Maybe' given a 'Data.ByteString.Strict.ByteString' --- for the 'Nothing' case and a 'Just' encode. -(< Encode a -> Encode (Maybe a) -(<>) -{-# INLINE (< Encode [s] -row enc = Encode $ \opts list -> join $ Seq.fromList $ fmap (getEncode enc opts) list - --- | Encode a single 'Char' -char :: Encode Char -char = escaped escapeChar BS.charUtf8 BS.stringUtf8 - --- | Encode an 'Int' -int :: Encode Int -int = unsafeBuilder BS.intDec - --- | Encode an 'Integer' -integer :: Encode Integer -integer = unsafeBuilder BS.integerDec - --- | Encode a 'Float' -float :: Encode Float -float = unsafeBuilder BS.floatDec - --- | Encode a 'Double' -double :: Encode Double -double = unsafeBuilder BS.doubleDec - --- | Encode a 'String' -string :: Encode String -string = escaped' escapeString BS.stringUtf8 - --- | Encode a 'Data.Text.Text' -text :: Encode T.Text -text = escaped' escapeText (BS.byteString . T.encodeUtf8) - --- | Encode a strict 'Data.ByteString.ByteString' -byteString :: Encode Strict.ByteString -byteString = escaped' escapeUtf8 BS.byteString - --- | Encode a lazy 'Data.ByteString.Lazy.ByteString' -lazyByteString :: Encode LBS.ByteString -lazyByteString = escaped' escapeUtf8Lazy BS.lazyByteString - -escaped :: Escaper s t -> (s -> BS.Builder) -> (t -> BS.Builder) -> Encode s -escaped esc sb tb = mkEncodeWithOpts $ \opts s -> - case _quote opts of - Nothing -> sb s - Just q -> tb $ esc (review quoteChar q) (Unescaped s) - -escaped' :: Escaper' s -> (s -> BS.Builder) -> Encode s -escaped' escaper = join (escaped escaper) - --- | Encode a 'Bool' as False or True -boolTrueFalse :: Encode Bool -boolTrueFalse = mkEncodeBS $ B.bool "False" "True" - --- | Encode a 'Bool' as false or true -booltruefalse :: Encode Bool -booltruefalse = mkEncodeBS $ B.bool "false" "true" - --- | Encode a 'Bool' as no or yes -boolyesno :: Encode Bool -boolyesno = mkEncodeBS $ B.bool "no" "yes" - --- | Encode a 'Bool' as No or Yes -boolYesNo :: Encode Bool -boolYesNo = mkEncodeBS $ B.bool "No" "Yes" - --- | Encode a 'Bool' as N or Y -boolYN :: Encode Bool -boolYN = mkEncodeBS $ B.bool "N" "Y" - --- | Encode a 'Bool' as 0 or 1 -bool10 :: Encode Bool -bool10 = mkEncodeBS $ B.bool "0" "1" - --- | Given an optic from @s@ to @a@, Try to use it to build an encode. --- --- @ --- encodeOf :: Iso' s a -> Encode a -> Encode s --- encodeOf :: Lens' s a -> Encode a -> Encode s --- encodeOf :: Prism' s a -> Encode a -> Encode s --- encodeOf :: Traversal' s a -> Encode a -> Encode s --- encodeOf :: Fold s a -> Encode a -> Encode s --- encodeOf :: Getter s a -> Encode a -> Encode s --- @ --- --- This is very useful when you have a prism for each constructor of your type. --- You can define an 'Encode' as follows: --- --- @ --- myEitherEncode :: Encode a -> Encode b -> Encode (Either a b) --- myEitherEncode encA encB = encodeOf _Left encA <> encodeOf _Right encB --- @ --- --- In this example, when the prism lookup returns 'Nothing', the empty encoder --- is returned. This is the 'mempty' for the 'Encode' monoid, so it won't --- add a field to the resulting CSV. This is the behaviour you want for --- combining a collection of prisms. --- --- But this encoder also works with lenses (or weaker optics), which will --- never fail their lookup, in which case it never returns 'mempty'. --- So this actually does the right thing for both sum and product types. -encodeOf :: Getting (First a) s a -> Encode a -> Encode s -encodeOf g = encodeOfMay g . choose (maybe (Left ()) Right) conquer - --- | Like 'encodeOf', but you can handle 'Nothing' however you'd like. --- In 'encodeOf', it is handled by the Encode which does nothing, --- but for example you might like to use 'orEmpty' to encode an empty field. -encodeOfMay :: Getting (First a) s a -> Encode (Maybe a) -> Encode s -encodeOfMay g x = contramap (preview g) x - --- | Encode a 'String' really quickly. --- If the string has quotes in it, they will not be escaped properly, so --- the result maybe not be valid CSV -unsafeString :: Encode String -unsafeString = unsafeBuilder BS.stringUtf8 - --- | Encode 'Data.Text.Text' really quickly. --- If the text has quotes in it, they will not be escaped properly, so --- the result maybe not be valid CSV -unsafeText :: Encode T.Text -unsafeText = unsafeBuilder (BS.byteString . T.encodeUtf8) - --- | Encode ByteString 'Data.ByteString.Builder.Builder' really quickly. --- If the builder builds a string with quotes in it, they will not be escaped --- properly, so the result maybe not be valid CSV -unsafeByteStringBuilder :: Encode BS.Builder -unsafeByteStringBuilder = unsafeBuilder id - --- | Encode a 'Data.ByteString.ByteString' really quickly. --- If the string has quotes in it, they will not be escaped properly, so --- the result maybe not be valid CSV -unsafeByteString :: Encode Strict.ByteString -unsafeByteString = unsafeBuilder BS.byteString - --- | Encode a 'Data.ByteString.Lazy.ByteString' really quickly. --- If the string has quotes in it, they will not be escaped properly, so --- the result maybe not be valid CSV -unsafeLazyByteString :: Encode LBS.ByteString -unsafeLazyByteString = unsafeBuilder BS.lazyByteString - --- | Encode this 'Data.ByteString.ByteString' really quickly every time, ignoring the input. --- If the string has quotes in it, they will not be escaped properly, so --- the result maybe not be valid CSV -unsafeConst :: Strict.ByteString -> Encode a -unsafeConst b = contramap (pure b) unsafeByteString - --- Added in containers 0.5.8, but we duplicate it here to support older GHCs -intersperseSeq :: a -> Seq a -> Seq a -intersperseSeq y xs = case viewl xs of - EmptyL -> S.empty - p :< ps -> p <| (ps <**> (pure y <| S.singleton id)) +import Data.Sv.Encode.Core diff --git a/src/Data/Sv/Encode/Options.hs b/src/Data/Sv/Encode/Options.hs deleted file mode 100644 --- a/src/Data/Sv/Encode/Options.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-| -Module : Data.Sv.Encode.Options -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -Options to configure encoding --} - -module Data.Sv.Encode.Options ( - EncodeOptions (EncodeOptions, _encodeSeparator, _spacingBefore, _spacingAfter, _quote, _newline, _terminalNewline) -, HasEncodeOptions (encodeOptions, spacingBefore, spacingAfter, quote, newline, terminalNewline) -, HasSeparator (..) -, defaultEncodeOptions -) where - -import Control.Lens (Lens') - -import Data.Sv.Syntax.Sv (Separator, HasSeparator (separator), comma) -import Text.Newline (Newline (CRLF)) -import Text.Space (Spaces) -import Text.Quote (Quote (DoubleQuote)) - --- | These are options to configure encoding. A default is provided as --- 'defaultEncodeOptions'. -data EncodeOptions = - EncodeOptions { - -- | Are your values separated by commas, tabs, or something else? Default: comma - _encodeSeparator :: Separator - -- | Between a comma and the next value, would you like some spacing? Default: no spacing - , _spacingBefore :: Spaces - -- | Between a value and the next comma, would you like some spacing? Default: no spacing - , _spacingAfter :: Spaces - -- | Would you like quotes around your values? If so, double quotes or single? Deafult: Double quotes - , _quote :: Maybe Quote - -- | What kind of newline would you like? Default: CRLF - , _newline :: Newline - -- | Should the file be terminated with a newline? Default: No - , _terminalNewline :: Bool - } - --- | Classy lenses for 'EncodeOptions' --- --- @ --- import Control.Lens --- --- defaultEncodeOptinons & quote .~ Just DoubleQuote & newline .~ LF --- @ -class HasSeparator c => HasEncodeOptions c where - encodeOptions :: Lens' c EncodeOptions - newline :: Lens' c Newline - {-# INLINE newline #-} - quote :: Lens' c (Maybe Quote) - {-# INLINE quote #-} - spacingAfter :: Lens' c Spaces - {-# INLINE spacingAfter #-} - spacingBefore :: Lens' c Spaces - {-# INLINE spacingBefore #-} - terminalNewline :: Lens' c Bool - {-# INLINE terminalNewline #-} - newline = encodeOptions . newline - quote = encodeOptions . quote - spacingAfter = encodeOptions . spacingAfter - spacingBefore = encodeOptions . spacingBefore - terminalNewline = encodeOptions . terminalNewline - -instance HasSeparator EncodeOptions where - separator f (EncodeOptions x1 x2 x3 x4 x5 x6) = - fmap (\ y -> EncodeOptions y x2 x3 x4 x5 x6) (f x1) - {-# INLINE separator #-} - -instance HasEncodeOptions EncodeOptions where - encodeOptions = id - {-# INLINE encodeOptions #-} - newline f (EncodeOptions x1 x2 x3 x4 x5 x6) = - fmap (\ y -> EncodeOptions x1 x2 x3 x4 y x6) (f x5) - {-# INLINE newline #-} - quote f (EncodeOptions x1 x2 x3 x4 x5 x6) = - fmap (\ y -> EncodeOptions x1 x2 x3 y x5 x6) (f x4) - {-# INLINE quote #-} - spacingAfter f (EncodeOptions x1 x2 x3 x4 x5 x6) = - fmap (\ y -> EncodeOptions x1 x2 y x4 x5 x6) (f x3) - {-# INLINE spacingAfter #-} - spacingBefore f (EncodeOptions x1 x2 x3 x4 x5 x6) = - fmap (\ y -> EncodeOptions x1 y x3 x4 x5 x6) (f x2) - {-# INLINE spacingBefore #-} - terminalNewline f (EncodeOptions x1 x2 x3 x4 x5 x6) = - fmap (\ y -> EncodeOptions x1 x2 x3 x4 x5 y) (f x6) - {-# INLINE terminalNewline #-} - --- | The default options for encoding. --- --- The default is a CSV file with double-quotes, CRLF lines, no spacing around --- fields, and no terminating newline. -defaultEncodeOptions :: EncodeOptions -defaultEncodeOptions = EncodeOptions comma mempty mempty (Just DoubleQuote) CRLF False diff --git a/src/Data/Sv/Encode/Type.hs b/src/Data/Sv/Encode/Type.hs deleted file mode 100644 --- a/src/Data/Sv/Encode/Type.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{-| -Module : Data.Sv.Encode.Type -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -The core type for encoding --} - -module Data.Sv.Encode.Type ( - Encode (Encode, getEncode) -) where - -import Data.Bifoldable (bifoldMap) -import qualified Data.ByteString.Builder as BS -import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Functor.Contravariant.Divisible (Divisible (divide, conquer), Decidable (choose, lose)) -import Data.Semigroup (Semigroup) -import Data.Sequence (Seq) -import Data.Void (absurd) - -import Data.Sv.Encode.Options - --- | An 'Encode' converts its argument into one or more textual fields, to be --- written out as CSV. --- --- It is 'Semigroup', Contravariant', 'Divisible', and 'Decidable', allowing --- for composition of these values to build bigger 'Encode's from smaller ones. -newtype Encode a = - Encode { getEncode :: EncodeOptions -> a -> Seq BS.Builder } - deriving (Semigroup, Monoid) - -instance Contravariant Encode where - contramap f (Encode g) = Encode $ fmap (. f) g - -instance Divisible Encode where - conquer = Encode mempty - divide f (Encode x) (Encode y) = - Encode $ \e a -> bifoldMap (x e) (y e) (f a) - -instance Decidable Encode where - lose f = Encode (const (absurd . f)) - choose f (Encode x) (Encode y) = - Encode $ \e a -> either (x e) (y e) (f a) diff --git a/src/Data/Sv/Parse.hs b/src/Data/Sv/Parse.hs --- a/src/Data/Sv/Parse.hs +++ b/src/Data/Sv/Parse.hs @@ -8,107 +8,44 @@ -} module Data.Sv.Parse ( - parseSv -, parseSv' -, parseSvFromFile -, parseSvFromFile' -, separatedValues - -, module Data.Sv.Parse.Options -, SvParser (..) -, trifecta -, attoparsecByteString -, attoparsecText + ParseOptions (..) +, defaultParseOptions +, defaultSeparator +, defaultHeadedness ) where -import Control.Lens (view) -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Data.Attoparsec.ByteString as BS (parseOnly) -import qualified Data.Attoparsec.Text as Text (parseOnly) -import Data.Bifunctor (first) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Text (Text) -import qualified Data.Text.IO as Text -import qualified Text.Trifecta as Tri - -import Data.Sv.Syntax.Sv (Sv) -import Data.Sv.Decode.Error (trifectaResultToEither) -import Data.Sv.Parse.Internal (separatedValues) -import Data.Sv.Parse.Options +import Data.Sv.Structure.Separator (Separator, HasSeparator (separator), comma) +import Data.Sv.Structure.Headedness (Headedness (Headed), HasHeadedness (headedness)) --- | Parse a 'ByteString' as an Sv. +-- | A 'ParseOptions' informs the parser how to parse your file. -- --- This version uses Trifecta, hence it assumes its input is UTF-8 encoded. -parseSv :: ParseOptions ByteString -> ByteString -> Either ByteString (Sv ByteString) -parseSv = parseSv' trifecta +-- A default is provided as 'defaultParseOptions', seen below. +data ParseOptions = + ParseOptions { + -- | Which separator does the file use? Usually this is 'comma', but it can + -- also be 'pipe', or any other 'Word8' ('Separator' = 'Word8') + _separator :: Separator --- | Parse some text as an Sv. --- --- This version lets you choose which parsing library to use by providing an --- 'SvParser'. Common selections are 'trifecta' and 'attoparsecByteString'. -parseSv' :: SvParser s -> ParseOptions s -> s -> Either s (Sv s) -parseSv' svp opts s = - let enc = view encodeString opts - in first enc $ runSvParser svp opts s + -- | Whether there is a header row with column names or not. + , _headedness :: Headedness + } --- | Load a file and parse it as an 'Sv'. --- --- This version uses Trifecta, hence it assumes its input is UTF-8 encoded. -parseSvFromFile :: MonadIO m => ParseOptions ByteString -> FilePath -> m (Either ByteString (Sv ByteString)) -parseSvFromFile = parseSvFromFile' trifecta +instance HasHeadedness ParseOptions where + headedness f (ParseOptions s h) = ParseOptions s <$> f h --- | Load a file and parse it as an 'Sv'. --- --- This version lets you choose which parsing library to use by providing an --- 'SvParser'. Common selections are 'trifecta' and 'attoparsecByteString'. -parseSvFromFile' :: MonadIO m => SvParser s -> ParseOptions s -> FilePath -> m (Either s (Sv s)) -parseSvFromFile' svp opts fp = - let enc = view encodeString opts - in liftIO (first enc <$> runSvParserFromFile svp opts fp) +instance HasSeparator ParseOptions where + separator f (ParseOptions s h) = (\y -> ParseOptions y h) <$> f s --- | Which parsing library should be used to parse the document? --- --- The parser is written in terms of the @parsers@ library, meaning it can be --- instantiated to several different parsing libraries. By default, we use --- 'trifecta', because "Text.Trifecta"s error messages are so helpful. --- 'attoparsecByteString' is faster though, if your input is ASCII and - -- you care a lot about speed. +-- | Default parsing options. -- --- It is worth noting that Trifecta assumes UTF-8 encoding of the input data. --- UTF-8 is backwards-compatible with 7-bit ASCII, so this will work for many --- documents. However, not all documents are ASCII or UTF-8. For example, our --- --- test file is Windows-1252, which is a non-ISO extension --- of latin1 8-bit ASCII. For documents encoded as Windows-1252, Trifecta's --- assumption is invalid and parse errors result. --- 'Attoparsec' works fine for this character encoding, but it wouldn't work --- well on a UTF-8 encoded document including non-ASCII characters. -data SvParser s = SvParser - { runSvParser :: ParseOptions s -> s -> Either String (Sv s) - , runSvParserFromFile :: ParseOptions s -> FilePath -> IO (Either String (Sv s)) - } - --- | An 'SvParser' that uses "Text.Trifecta". Trifecta assumes its input is UTF-8, and --- provides helpful clang-style error messages. -trifecta :: SvParser ByteString -trifecta = SvParser - { runSvParser = \opts bs -> trifectaResultToEither $ Tri.parseByteString (separatedValues opts) mempty bs - , runSvParserFromFile = \opts fp -> trifectaResultToEither <$> Tri.parseFromFileEx (separatedValues opts) fp - } +-- The default is a comma separator, with a header at the top of the file. +defaultParseOptions :: ParseOptions +defaultParseOptions = ParseOptions defaultSeparator defaultHeadedness --- | An 'SvParser' that uses "Data.Attoparsec.ByteString". This is the fastest --- provided 'SvParser', but it has poorer error messages. -attoparsecByteString :: SvParser ByteString -attoparsecByteString = SvParser - { runSvParser = \opts bs -> BS.parseOnly (separatedValues opts) bs - , runSvParserFromFile = \opts fp -> BS.parseOnly (separatedValues opts) <$> BS.readFile fp - } +-- | The default separator is comma. +defaultSeparator :: Separator +defaultSeparator = comma --- | An 'SvParser' that uses "Data.Attoparsec.Text". This is helpful if --- your input is in the form of 'Text'. -attoparsecText :: SvParser Text -attoparsecText = SvParser - { runSvParser = \opts t -> Text.parseOnly (separatedValues opts) t - , runSvParserFromFile = \opts fp -> Text.parseOnly (separatedValues opts) <$> Text.readFile fp - } +-- | The default is that a header is present. +defaultHeadedness :: Headedness +defaultHeadedness = Headed diff --git a/src/Data/Sv/Parse/Internal.hs b/src/Data/Sv/Parse/Internal.hs deleted file mode 100644 --- a/src/Data/Sv/Parse/Internal.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-| -Module : Data.Sv.Parse.Internal -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -This module contains internal implementation details of sv's parser. -As the Internal name suggests, this file is exempt from the PVP. Depend -on this module at your own risk! --} - -module Data.Sv.Parse.Internal ( - separatedValues - , header - , field - , singleQuotedField - , doubleQuotedField - , unquotedField - , spaced - , spacedField - , record - , records - , ending -) where - -import Control.Applicative (Alternative ((<|>), empty), optional) -import Control.Lens (review, view) -import Data.CharSet (CharSet, (\\)) -import qualified Data.CharSet as CharSet (fromList, insert, singleton) -import Data.Functor (($>), (<$>), void) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Maybe (fromMaybe) -import Data.Semigroup ((<>)) -import qualified Data.Vector as V -import Text.Parser.Char (CharParsing, char, notChar, noneOfSet, oneOfSet, string) -import Text.Parser.Combinators (between, choice, eof, many, notFollowedBy, sepEndBy, try) - -import Data.Sv.Syntax.Sv (Sv (Sv), Header, mkHeader, noHeader, Headedness (Unheaded, Headed), headedness, Separator) -import Data.Sv.Syntax.Field (Field (Unquoted, Quoted)) -import Data.Sv.Syntax.Record (Record (Record), Records (Records, EmptyRecords)) -import Data.Sv.Parse.Options (ParseOptions, separator, endOnBlankLine, encodeString) -import Data.Vector.NonEmpty as V -import Text.Escape (Unescaped (Unescaped)) -import Text.Newline (Newline (CR, CRLF, LF)) -import Text.Space (HorizontalSpace (Space, Tab), Spaces, Spaced, betwixt) -import Text.Quote (Quote (SingleQuote, DoubleQuote), quoteChar) - --- | This function is in newer versions of the parsers package, but in --- order to maintain compatibility with older versions I've left it here. -sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) - --- | Parse a field surrounded by single quotes -singleQuotedField :: CharParsing m => (String -> s) -> m (Field s) -singleQuotedField = quotedField SingleQuote - --- | Parse a field surrounded by double quotes -doubleQuotedField :: CharParsing m => (String -> s) -> m (Field s) -doubleQuotedField = quotedField DoubleQuote - --- | Given a quote, parse its escaped form (which is it repeated twice) -escapeQuote :: CharParsing m => Quote -> m Char -escapeQuote q = - let c = review quoteChar q - in try (string (two c)) $> c - -two :: a -> [a] -two a = [a,a] - -quotedField :: CharParsing m => Quote -> (String -> s) -> m (Field s) -quotedField quote str = - let q = review quoteChar quote - c = char q - cc = escapeQuote quote - in Quoted quote . Unescaped . str <$> between c c (many (cc <|> notChar q)) - --- | Parse a field that is not surrounded by quotes -unquotedField :: CharParsing m => Separator -> (String -> s) -> m (Field s) -unquotedField sep str = - let spaceSet = CharSet.fromList " \t" \\ CharSet.singleton sep - oneSpace = oneOfSet spaceSet - nonSpaceFieldChar = noneOfSet (newlineOr sep <> spaceSet) - terminalWhitespace = many oneSpace *> fieldEnder - fieldEnder = void (oneOfSet (newlineOr sep)) <|> eof - in Unquoted . str <$> - many ( - nonSpaceFieldChar - <|> (notFollowedBy (try terminalWhitespace)) *> oneSpace - ) - --- | Parse a field, be it quoted or unquoted -field :: CharParsing m => Separator -> (String -> s) -> m (Field s) -field sep str = - choice [ - singleQuotedField str - , doubleQuotedField str - , unquotedField sep str - ] - --- | Parse a field with its surrounding spacing -spacedField :: CharParsing m => Separator -> (String -> s) -> m (Spaced (Field s)) -spacedField sep str = spaced sep (field sep str) - -newlineOr :: Char -> CharSet -newlineOr c = CharSet.insert c newlines - -newlines :: CharSet -newlines = CharSet.fromList "\r\n" - -newline :: CharParsing m => m Newline -newline = - CRLF <$ try (string "\r\n") - <|> CR <$ char '\r' - <|> LF <$ char '\n' - -space :: CharParsing m => Separator -> m HorizontalSpace -space sep = - let removeIfSep c s = if sep == c then empty else char c $> s - in removeIfSep ' ' Space <|> removeIfSep '\t' Tab - -spaces :: CharParsing m => Separator -> m Spaces -spaces = fmap V.fromList . many . space - --- | Combinator to parse some data surrounded by spaces -spaced :: CharParsing m => Separator -> m a -> m (Spaced a) -spaced sep p = betwixt <$> spaces sep <*> p <*> spaces sep - --- | Parse an entire record, or "row" -record :: CharParsing m => ParseOptions s -> m (Record s) -record opts = - let sep = view separator opts - str = view encodeString opts - in Record . V.fromNel <$> (spacedField sep str `sepEndByNonEmpty` char sep) - --- | Parse many records, or "rows" -records :: CharParsing m => ParseOptions s -> m (Records s) -records opts = - let manyV = fmap V.fromList . many - in fromMaybe EmptyRecords <$> - optional (Records <$> firstRecord opts <*> manyV (subsequentRecord opts)) - -firstRecord :: CharParsing m => ParseOptions s -> m (Record s) -firstRecord opts = notFollowedBy (try (ending opts)) *> record opts - -subsequentRecord :: CharParsing m => ParseOptions s -> m (Newline, Record s) -subsequentRecord opts = - (,) - <$> (notFollowedBy (try (ending opts)) *> newline) -- ((if view endOnBlankLine opts then (void newline) else empty) <|> eof)) - <*> record opts - --- | Parse zero or many newlines -ending :: CharParsing m => ParseOptions s -> m [Newline] -ending opts = - let end = if view endOnBlankLine opts then pure [] else many newline - in [] <$ eof - <|> try (pure <$> newline <* eof) - <|> (:) <$> newline <*> ((:) <$> newline <*> end) - --- | Maybe parse the header row of a CSV file, depending on the given 'Headedness' -header :: CharParsing m => ParseOptions s -> m (Maybe (Header s)) -header opts = case view headedness opts of - Unheaded -> pure noHeader - Headed -> mkHeader <$> record opts <*> newline - --- | Parse an 'Sv' -separatedValues :: CharParsing m => ParseOptions s -> m (Sv s) -separatedValues opts = - Sv (view separator opts) <$> header opts <*> records opts <*> ending opts diff --git a/src/Data/Sv/Parse/Options.hs b/src/Data/Sv/Parse/Options.hs deleted file mode 100644 --- a/src/Data/Sv/Parse/Options.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DefaultSignatures #-} - -{-| -Module : Data.Sv.Parse.Options -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -Configuration to tell the parser what your file looks like. --} - -module Data.Sv.Parse.Options ( - ParseOptions (ParseOptions, _headedness, _endOnBlankLine, _parseSeparator, _encodeString) -, HasParseOptions (parseOptions, endOnBlankLine, encodeString) -, HasSeparator (..) -, HasHeadedness (..) -, defaultParseOptions -, defaultHeadedness -, defaultSeparator -) where - -import Control.Lens (Lens, lens) -import Data.ByteString.UTF8 (ByteString, fromString) - -import Data.Sv.Syntax.Sv (HasSeparator (separator), HasHeadedness (headedness), Headedness (Headed), Separator, comma) - --- | An 'ParseOptions' informs the parser how to parse your file. The type --- parameter will be some sort of string; often 'Data.ByteString.ByteString'. --- --- A default is provided as 'defaultParseOptions', seen below. -data ParseOptions s = - ParseOptions { - -- | Which separator does the file use? Usually this is 'comma', but it can - -- also be 'pipe', or any other 'Char' ('Separator' = 'Char') - _parseSeparator :: Separator - - -- | Whether there is a header row with column names or not. - , _headedness :: Headedness - - -- | If a blank line is encountered, should the parse finish, or treat it as - -- an empty row and continue? - , _endOnBlankLine :: Bool - - -- | How should I turn a String into this type? This is a detail used by the parser. - , _encodeString :: String -> s - } - -instance Functor ParseOptions where - fmap f (ParseOptions s h e enc) = ParseOptions s h e (f . enc) - --- | Classy lenses for 'ParseOptions' -class (HasSeparator s, HasHeadedness s) => HasParseOptions s t a b | s -> a, t -> b, s b -> t, t a -> s where - parseOptions :: Lens s t (ParseOptions a) (ParseOptions b) - encodeString :: Lens s t (String -> a) (String -> b) - {-# INLINE encodeString #-} - endOnBlankLine :: s ~ t => Lens s t Bool Bool - {-# INLINE endOnBlankLine #-} - encodeString = parseOptions . encodeString - default endOnBlankLine :: (s ~ t, a ~ b) => Lens s t Bool Bool - endOnBlankLine = parseOptions . endOnBlankLine - -instance HasParseOptions (ParseOptions a) (ParseOptions b) a b where - parseOptions = id - {-# INLINE parseOptions #-} - encodeString = lens _encodeString (\c s -> c { _encodeString = s }) - {-# INLINE encodeString #-} - endOnBlankLine = lens _endOnBlankLine (\c b -> c { _endOnBlankLine = b }) - {-# INLINE endOnBlankLine #-} - -instance HasSeparator (ParseOptions s) where - separator = - lens _parseSeparator (\c s -> c { _parseSeparator = s }) - {-# INLINE separator #-} - -instance HasHeadedness (ParseOptions s) where - headedness = - lens _headedness (\c h -> c { _headedness = h }) - {-# INLINE headedness #-} - --- | 'defaultParseOptions' is used to parse a CSV file featuring a header row, using --- Trifecta as the parsing library. It uses UTF-8 'ByteString's -defaultParseOptions :: ParseOptions ByteString -defaultParseOptions = ParseOptions defaultSeparator defaultHeadedness False fromString - --- | The default separator. Alias for 'comma'. -defaultSeparator :: Separator -defaultSeparator = comma - --- | The default is that a header is present. -defaultHeadedness :: Headedness -defaultHeadedness = Headed diff --git a/src/Data/Sv/Print.hs b/src/Data/Sv/Print.hs deleted file mode 100644 --- a/src/Data/Sv/Print.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-| -Module : Data.Sv.Print -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -Printing is the process of turning an 'Data.Sv.Syntax.Sv.Sv' into a textual -representation, such as a 'Data.ByteString.ByteString'. - -If you want to turn your data type into a textual representation, you should -look instead at "Data.Sv.Encode" --} - -module Data.Sv.Print ( - printSv -, printSvLazy -, printSv' -, printSvLazy' -, printSvText -, printSvTextLazy -, writeSvToFile -, writeSvToHandle -, writeSvToFile' -, writeSvToHandle' -, module Data.Sv.Print.Options -) where - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LBS -import Data.ByteString.Builder as Builder -import Data.Semigroup ((<>)) -import Data.Text (Text) -import System.IO (BufferMode (BlockBuffering), Handle, hClose, hSetBinaryMode, hSetBuffering, openFile, IOMode (WriteMode)) - -import Data.Sv.Print.Options -import Data.Sv.Print.Internal -import Data.Sv.Syntax.Sv (Sv (Sv)) - --- | Converts an 'Sv' to a ByteString 'Builder'. Useful if you want to concatenate other --- text before or after. -svToBuilder :: PrintOptions s -> Sv s -> Builder -svToBuilder opts (Sv sep h rs e) = - foldMap (printHeader opts sep) h <> printRecords opts sep rs <> foldMap printNewline e - --- | Writes an sv to a file handle. This goes directly from a 'Builder', so it is --- more efficient than calling 'printSv' or 'printSvLazy' and writing the --- result to the handle. -writeSvToHandle :: Handle -> Sv ByteString -> IO () -writeSvToHandle = writeSvToHandle' defaultPrintOptions - --- | Writes an sv to a file. This goes directly from a 'Builder', so it is --- more efficient than calling 'printSv' or 'printSvLazy' and writing the --- result to a file. -writeSvToFile :: FilePath -> Sv ByteString -> IO () -writeSvToFile = writeSvToFile' defaultPrintOptions - --- | Writes an sv to a file handle. This goes directly from a 'Builder', so it is --- more efficient than calling 'printSv' or 'printSvLazy' and writing the --- result to the handle. --- --- This version is polymorphic, but as a penalty you have to tell me how to --- get a Bytestring 'Builder'. -writeSvToHandle' :: PrintOptions s -> Handle -> Sv s -> IO () -writeSvToHandle' opts h sv = hPutBuilder h (svToBuilder opts sv) - --- | Writes an sv to a file. This goes directly from a 'Builder', so it is --- more efficient than calling 'printSv' or 'printSvLazy' and writing the --- result to a file. --- --- This version is polymorphic, but as a penalty you have to tell me how to --- get a Bytestring 'Builder'. -writeSvToFile' :: PrintOptions s -> FilePath -> Sv s -> IO () -writeSvToFile' opts fp sv = do - h <- openFile fp WriteMode - hSetBuffering h (BlockBuffering Nothing) - hSetBinaryMode h True - writeSvToHandle' opts h sv - hClose h - --- | Print an Sv to a 'Data.ByteString.ByteString' value. -printSv :: Sv ByteString -> ByteString -printSv = printSv' defaultPrintOptions - --- | Print an Sv to a lazy 'Data.ByteString.Lazy.ByteString' value. -printSvLazy :: Sv ByteString -> LBS.ByteString -printSvLazy = printSvLazy' defaultPrintOptions - --- | Converts the given 'Sv' into a strict 'Data.ByteString.ByteString' -printSv' :: PrintOptions s -> Sv s -> ByteString -printSv' opts = LBS.toStrict . printSvLazy' opts - --- | Converts the given 'Sv' into a lazy 'Data.ByteString.Lazy.ByteString' -printSvLazy' :: PrintOptions s -> Sv s -> LBS.ByteString -printSvLazy' opts = toLazyByteString . svToBuilder opts - --- | Print an Sv containing 'Text' to a 'Data.ByteString.ByteString' -printSvText :: Sv Text -> ByteString -printSvText = printSv' textPrintOptions - --- | Print an Sv containing 'Text' to a 'Data.ByteString.Lazy.ByteString' -printSvTextLazy :: Sv Text -> LBS.ByteString -printSvTextLazy = printSvLazy' textPrintOptions diff --git a/src/Data/Sv/Print/Internal.hs b/src/Data/Sv/Print/Internal.hs deleted file mode 100644 --- a/src/Data/Sv/Print/Internal.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-| -Module : Data.Sv.Print.Internal -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -This module is considered an implementation detail. -As the "Internal" module name suggests, this module is exempt from -the PVP, so depend on it at your own risk! -These functions exist to be called by "Data.Sv.Print". --} - -module Data.Sv.Print.Internal ( - printNewline - , printField - , printSpaced - , printRecord - , printRecords - , printHeader -) where - -import Control.Lens (review, view) -import Data.Bifoldable (bifoldMap) -import Data.ByteString.Builder as Builder -import Data.Semigroup ((<>)) -import Data.Semigroup.Foldable (intercalate1) - -import Data.Sv.Print.Options -import Data.Sv.Syntax.Field (Field (Quoted, Unquoted), SpacedField) -import Data.Sv.Syntax.Record (Record (Record), Records (Records, EmptyRecords)) -import Data.Sv.Syntax.Sv (Header (Header), Separator) -import Text.Newline -import Text.Space (spaceToChar, Spaced (Spaced)) -import Text.Quote - --- | Convert a 'Newline' to a ByteString 'Builder' -printNewline :: Newline -> Builder -printNewline = Builder.lazyByteString . newlineToString - --- | Convert a 'Field' to a ByteString 'Builder' -printField :: PrintOptions s -> Field s -> Builder -printField opts f = - case f of - Unquoted s -> - view build opts s - Quoted q s -> - let qc = quoteToString q - contents = view build opts $ view escape opts (review quoteChar q) s - in qc <> contents <> qc - --- | Convert a 'SpacedField' to a ByteString 'Builder' -printSpaced :: PrintOptions s -> SpacedField s -> Builder -printSpaced opts (Spaced b t a) = - let spc = foldMap (Builder.charUtf8 . spaceToChar) - in spc b <> printField opts a <> spc t - --- | Convert a 'Record' to a ByteString 'Builder' -printRecord :: PrintOptions s -> Separator -> Record s -> Builder -printRecord opts sep (Record fs) = - intercalate1 (Builder.charUtf8 sep) (fmap (printSpaced opts) fs) - --- | Convert 'Records' to a ByteString 'Builder'. -printRecords :: PrintOptions s -> Separator -> Records s -> Builder -printRecords opts sep rs = case rs of - EmptyRecords -> mempty - Records a as -> - printRecord opts sep a <> foldMap (bifoldMap printNewline (printRecord opts sep)) as - --- | Convert 'Header' to a ByteString 'Builder'. -printHeader :: PrintOptions s -> Separator -> Header s -> Builder -printHeader opts sep (Header r n) = printRecord opts sep r <> printNewline n diff --git a/src/Data/Sv/Print/Options.hs b/src/Data/Sv/Print/Options.hs deleted file mode 100644 --- a/src/Data/Sv/Print/Options.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} - -{-| -Module : Data.Sv.Print.Options -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable --} - -module Data.Sv.Print.Options ( - PrintOptions (..) - , HasPrintOptions (..) - , defaultPrintOptions - , utf8PrintOptions - , utf8LazyPrintOptions - , textPrintOptions - , stringPrintOptions -) where - -import Control.Lens -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as Builder -import Data.Text (Text) -import qualified Data.Text.Encoding as Text - -import Text.Escape (Escaper', escapeUtf8, escapeUtf8Lazy, escapeText, escapeString) - --- | Options to configure the printing process -data PrintOptions a = - PrintOptions { - -- | How do I convert these values into ByteString 'Builder's? This depends - -- not only on type, but on character encoding. Default: 'utf8PrintOptions' - _build :: a -> Builder - -- | How do I escape quotes which appear in this value? Default: 'escapeUtf8' - , _escape :: Escaper' a - } - --- | Classy optics for 'PrintOptions' -class HasPrintOptions c a | c -> a where - printOptions :: Lens' c (PrintOptions a) - build :: Lens' c (a -> Builder) - {-# INLINE build #-} - escape :: Lens' c (Escaper' a) - {-# INLINE escape #-} - build = printOptions . build - escape = printOptions . escape - -instance HasPrintOptions (PrintOptions a) a where - printOptions = id - {-# INLINE printOptions #-} - build f (PrintOptions x1 x2) = fmap (\ y -> PrintOptions y x2) (f x1) - {-# INLINE build #-} - escape f (PrintOptions x1 x2) = fmap (PrintOptions x1) (f x2) - {-# INLINE escape #-} - --- | Print options for 'Sv's containing UTF-8 bytestrings -defaultPrintOptions :: PrintOptions BS.ByteString -defaultPrintOptions = utf8PrintOptions - --- | Print options for 'Sv's containing UTF-8 bytestrings -utf8PrintOptions :: PrintOptions BS.ByteString -utf8PrintOptions = PrintOptions Builder.byteString escapeUtf8 - --- | Print options for 'Sv's containing UTF-8 lazy bytestrings -utf8LazyPrintOptions :: PrintOptions BL.ByteString -utf8LazyPrintOptions = PrintOptions Builder.lazyByteString escapeUtf8Lazy - --- | Print options for 'Sv's containing 'Text' -textPrintOptions :: PrintOptions Text -textPrintOptions = PrintOptions (Builder.byteString . Text.encodeUtf8) escapeText - --- | Print options for 'Sv's containing 'String's -stringPrintOptions :: PrintOptions String -stringPrintOptions = PrintOptions Builder.stringUtf8 escapeString diff --git a/src/Data/Sv/Structure.hs b/src/Data/Sv/Structure.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Structure.hs @@ -0,0 +1,14 @@ +{-| +Module : Data.Sv.Structure +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +Stability : experimental +Portability : non-portable +-} + +module Data.Sv.Structure ( + module Data.Sv.Structure.Core +) where + +import Data.Sv.Structure.Core diff --git a/src/Data/Sv/Syntax.hs b/src/Data/Sv/Syntax.hs deleted file mode 100644 --- a/src/Data/Sv/Syntax.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-| -Module : Data.Sv.Syntax -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable --} - -module Data.Sv.Syntax ( - module Data.Sv.Syntax.Field -, module Data.Sv.Syntax.Record -, module Data.Sv.Syntax.Sv -) where - -import Data.Sv.Syntax.Field -import Data.Sv.Syntax.Record -import Data.Sv.Syntax.Sv diff --git a/src/Data/Sv/Syntax/Field.hs b/src/Data/Sv/Syntax/Field.hs deleted file mode 100644 --- a/src/Data/Sv/Syntax/Field.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveGeneric #-} - -{-| -Module : Data.Sv.Syntax.Field -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable --} - -module Data.Sv.Syntax.Field ( - Field (Unquoted, Quoted) - , SpacedField - , Spaced (Spaced) - , HasFields (fields) - , AsField (_Field, _Unquoted, _Quoted) - , unescapedField - , foldField - , fieldContents -) where - -import Control.DeepSeq (NFData) -import Control.Lens (Lens, Prism', Traversal, lens, prism) -import Data.Foldable (Foldable (foldMap)) -import Data.Functor (Functor (fmap)) -import Data.Traversable (Traversable (traverse)) -import GHC.Generics (Generic) - -import Text.Escape (Unescaped (Unescaped, getRawUnescaped)) -import Text.Quote (Quote) -import Text.Space (Spaced (Spaced)) - --- | A 'Field' is a single cell from a CSV document. --- --- Its value is either 'Quoted', which indicates the type of quote --- surrounding the value, or it is 'Unquoted', containing only the value. -data Field s = - Unquoted s - | Quoted Quote (Unescaped s) - deriving (Eq, Ord, Show, Generic) - -instance NFData s => NFData (Field s) - -instance Functor Field where - fmap f fi = case fi of - Unquoted s -> Unquoted (f s) - Quoted q v -> Quoted q (fmap f v) - -instance Foldable Field where - foldMap f fi = case fi of - Unquoted s -> f s - Quoted _ v -> foldMap f v - -instance Traversable Field where - traverse f fi = case fi of - Unquoted s -> Unquoted <$> f s - Quoted q v -> Quoted q <$> traverse f v - --- | 'Field's are often surrounded by spaces -type SpacedField a = Spaced (Field a) - --- | Classy prisms for 'Field' -class (HasFields s s a a) => AsField s a | s -> a where - _Field :: Prism' s (Field a) - _Unquoted :: Prism' s a - _Quoted :: Prism' s (Quote, Unescaped a) - _Unquoted = _Field . _Unquoted - {-# INLINE _Unquoted #-} - _Quoted = _Field . _Quoted - {-# INLINE _Quoted #-} - -instance AsField (Field a) a where - _Field = id - {-# INLINE _Field #-} - _Unquoted = prism Unquoted - (\x -> case x of - Unquoted y -> Right y - _ -> Left x - ) - {-# INLINE _Unquoted #-} - _Quoted = prism (uncurry Quoted) - (\x -> case x of - Quoted y z -> Right (y,z) - _ -> Left x - ) - {-# INLINE _Quoted #-} - --- | Classy 'Traversal'' for things containing 'Field's -class HasFields c d s t | c -> s, d -> t, c t -> d, d s -> c where - fields :: Traversal c d (Field s) (Field t) - -instance HasFields (Field s) (Field t) s t where - fields = id - {-# INLINE fields #-} - --- | Build a quoted field with a normal string -unescapedField :: Quote -> s -> Field s -unescapedField q s = Quoted q (Unescaped s) - --- | The catamorphism for @Field'@ -foldField :: (s -> b) -> (Quote -> Unescaped s -> b) -> Field s -> b -foldField u q fi = case fi of - Unquoted s -> u s - Quoted a b -> q a b - --- | Lens into the contents of a Field, regardless of whether it's quoted or unquoted -fieldContents :: Lens (Field s) (Field t) s t -fieldContents = - lens (foldField id (const getRawUnescaped)) $ \f b -> case f of - Unquoted _ -> Unquoted b - Quoted q _ -> Quoted q (Unescaped b) diff --git a/src/Data/Sv/Syntax/Record.hs b/src/Data/Sv/Syntax/Record.hs deleted file mode 100644 --- a/src/Data/Sv/Syntax/Record.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveGeneric #-} - -{-| -Module : Data.Sv.Syntax.Record -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -This module contains datatypes for Records. A record is a "line" or "row" -of a CSV document --} -module Data.Sv.Syntax.Record ( - Record (Record, _fields) - -- Optics - , HasRecord (record, spacedFields) - , recordSpacedFieldsIso - , emptyRecord - , singleField - , recordNel - , Records (EmptyRecords, Records) - , HasRecords (records, traverseRecords, traverseNewlines) - , _EmptyRecords - , _NonEmptyRecords - , mkRecords - , singleRecord - , recordList -) where - -import Control.DeepSeq (NFData) -import Control.Lens (Lens, Lens', Iso, Prism, Prism', Traversal', _1, _2, beside, iso, prism, prism', toListOf) -import Data.Foldable (Foldable (foldMap)) -import Data.Functor (Functor (fmap)) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Semigroup (Semigroup) -import Data.Traversable (Traversable (traverse)) -import GHC.Generics (Generic) - -import Data.Sv.Syntax.Field (SpacedField, Field (Unquoted), HasFields (fields)) -import Data.Vector.NonEmpty (NonEmptyVector) -import Data.Vector (Vector) -import qualified Data.Vector as V -import qualified Data.Vector.NonEmpty as V -import Text.Newline (Newline) -import Text.Space (Spaced, spacedValue) - --- | A @Record@ is a non-empty collection of Fields, implicitly separated --- by a separator (often a comma). -newtype Record s = - Record { - _fields :: NonEmptyVector (Spaced (Field s)) - } - deriving (Eq, Ord, Show, Semigroup, Generic) - -instance NFData s => NFData (Record s) - --- | A 'Record' is isomorphic to a 'NonEmpty' list of 'SpacedField's -recordSpacedFieldsIso :: Iso (Record s) (Record a) (NonEmptyVector (Spaced (Field s))) (NonEmptyVector (Spaced (Field a))) -recordSpacedFieldsIso = iso _fields Record -{-# INLINE recordSpacedFieldsIso #-} - --- | Classy lenses for 'Record' -class HasRecord s t a b | s -> a, t -> b where - record :: Lens s t (Record a) (Record b) - spacedFields :: Lens s t (NonEmptyVector (Spaced (Field a))) (NonEmptyVector (Spaced (Field b))) - {-# INLINE spacedFields #-} - spacedFields = record . spacedFields - -instance HasRecord (Record a) (Record b) a b where - record = id - {-# INLINE record #-} - spacedFields = recordSpacedFieldsIso - {-# INLINE spacedFields #-} - -instance HasFields (Record a) (Record b) a b where - fields = spacedFields . traverse . spacedValue - -instance Functor Record where - fmap f = Record . fmap (fmap (fmap f)) . _fields - -instance Foldable Record where - foldMap f = foldMap (foldMap (foldMap f)) . _fields - -instance Traversable Record where - traverse f = fmap Record . traverse (traverse (traverse f)) . _fields - --- | Build an empty record. --- --- According to RFC 4180, a record must have at least one field. --- But a field can be the empty string. So this is the closest we can get to --- an empty record. --- --- Note that this does not make 'Record' a 'Monoid'. It is not a lawful unit --- for the 'Semigroup' operation. -emptyRecord :: Monoid s => Record s -emptyRecord = singleField (Unquoted mempty) - --- | Build a 'Record' with just one 'Field' -singleField :: Field s -> Record s -singleField = Record . pure . pure - --- | Build a 'Record' given a 'NonEmpty' list of its fields -recordNel :: NonEmpty (SpacedField s) -> Record s -recordNel = Record . V.fromNel - --- | A collection of records, separated by newlines. -data Records s = - EmptyRecords - | Records (Record s) (Vector (Newline, Record s)) - deriving (Eq, Ord, Show, Generic) - -instance NFData s => NFData (Records s) - --- | Prism for an empty 'Records' -_EmptyRecords :: Prism' (Records s) () -_EmptyRecords = - prism' (const EmptyRecords) $ \r -> - case r of - EmptyRecords -> Just () - Records _ _ -> Nothing - --- | Prism for a non-empty 'Records' -_NonEmptyRecords :: Prism (Records s) (Records t) (Record s, Vector (Newline, Record s)) (Record t, Vector (Newline, Record t)) -_NonEmptyRecords = - prism (uncurry Records) $ \r -> - case r of - EmptyRecords -> Left EmptyRecords - Records a as -> Right (a,as) - --- | Classy lenses for 'Records' -class HasRecords c s | c -> s where - records :: Lens' c (Records s) - traverseRecords :: Traversal' c (Record s) - traverseRecords = records . _NonEmptyRecords . beside id (traverse . _2) - {-# INLINE traverseRecords #-} - traverseNewlines :: Traversal' c Newline - traverseNewlines = records . _NonEmptyRecords . _2 . traverse . _1 - -instance HasRecords (Records s) s where - records = id - {-# INLINE records #-} - -instance Functor Records where - fmap f rs = case rs of - EmptyRecords -> EmptyRecords - Records a as -> Records (fmap f a) (fmap (fmap (fmap f)) as) - -instance Foldable Records where - foldMap f rs = case rs of - EmptyRecords -> mempty - Records a as -> foldMap f a `mappend` foldMap (foldMap (foldMap f)) as - -instance Traversable Records where - traverse f rs = case rs of - EmptyRecords -> pure EmptyRecords - Records a as -> Records <$> traverse f a <*> traverse (traverse (traverse f)) as - --- | Convenience constructor for 'Records'. --- --- This puts the same newline between all the records. -mkRecords :: Newline -> NonEmpty (Record s) -> Records s -mkRecords n (r:|rs) = Records r (V.fromList (fmap (n,) rs)) - --- | A record collection conaining one record -singleRecord :: Record s -> Records s -singleRecord s = Records s V.empty - --- | Collect the list of 'Record's from anything that 'HasRecords' -recordList :: HasRecords c s => c -> [Record s] -recordList = toListOf traverseRecords diff --git a/src/Data/Sv/Syntax/Sv.hs b/src/Data/Sv/Syntax/Sv.hs deleted file mode 100644 --- a/src/Data/Sv/Syntax/Sv.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances#-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveGeneric #-} - -{-| -Module : Data.Sv.Syntax.Sv -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -This file defines a datatype for a complete Sv document. -The datatype preserves information such as whitespace so that the original -text can be recovered. - -In the usual workflow, this type is only an intermediate stage between -parsing and decoding. You can program against it directly using the provided -functions and optics if you'd like. For an example of this see - --} - -module Data.Sv.Syntax.Sv ( - Sv (Sv, _separatorSv, _maybeHeader, _records, _finalNewlines) - , HasSv (sv, maybeHeader, traverseHeader, finalNewlines) - , HasRecords (records, traverseNewlines, traverseRecords) - , mkSv - , emptySv - , recordList - , Header (Header, _headerRecord) - , HasHeader (header, headerRecord, headerNewline) - , noHeader - , mkHeader - , Headedness (Unheaded, Headed) - , HasHeadedness (headedness) - , getHeadedness - , Separator - , HasSeparator (separator) - , comma - , pipe - , tab -) where - -import Control.DeepSeq (NFData) -import Control.Lens (Lens, Lens', Traversal') -import Data.Foldable (Foldable (foldMap)) -import Data.Functor (Functor (fmap), (<$>)) -import Data.Monoid ((<>)) -import Data.Traversable (Traversable (traverse)) -import GHC.Generics (Generic) - -import Data.Sv.Syntax.Field (HasFields (fields)) -import Data.Sv.Syntax.Record (Record, Records (EmptyRecords), HasRecord (record), HasRecords (records, traverseNewlines, traverseRecords), recordList) -import Text.Newline (Newline) - --- | 'Sv' is a whitespace-preserving data type for separated values. --- Often the separator is a comma, but this type does not make that --- assumption so that it can be used for pipe- or tab-separated values --- as well. -data Sv s = - Sv { - _separatorSv :: Separator - , _maybeHeader :: Maybe (Header s) - , _records :: Records s - , _finalNewlines :: [Newline] - } - deriving (Eq, Ord, Show, Generic) - -instance NFData s => NFData (Sv s) - --- | Classy lenses for 'Sv' -class (HasRecords c s, HasSeparator c) => HasSv c s | c -> s where - sv :: Lens' c (Sv s) - maybeHeader :: Lens' c (Maybe (Header s)) - {-# INLINE maybeHeader #-} - traverseHeader :: Traversal' c (Header s) - {-# INLINE traverseHeader #-} - finalNewlines :: Lens' c [Newline] - {-# INLINE finalNewlines #-} - maybeHeader = sv . maybeHeader - traverseHeader = maybeHeader . traverse - finalNewlines = sv . finalNewlines - -instance HasRecords (Sv s) s where - records f (Sv x1 x2 x3 x4) = - fmap (\y -> Sv x1 x2 y x4) (f x3) - {-# INLINE records #-} - -instance HasSv (Sv s) s where - sv = id - {-# INLINE sv #-} - maybeHeader f (Sv x1 x2 x3 x4) = - fmap (\y -> Sv x1 y x3 x4) (f x2) - {-# INLINE maybeHeader #-} - finalNewlines f (Sv x1 x2 x3 x4) = - fmap (Sv x1 x2 x3) (f x4) - {-# INLINE finalNewlines #-} - --- | Convenience constructor for Sv -mkSv :: Separator -> Maybe (Header s) -> [Newline] -> Records s -> Sv s -mkSv c h ns rs = Sv c h rs ns - --- | An empty Sv -emptySv :: Separator -> Sv s -emptySv c = Sv c Nothing EmptyRecords [] - -instance Functor Sv where - fmap f (Sv s h rs e) = Sv s (fmap (fmap f) h) (fmap f rs) e - -instance Foldable Sv where - foldMap f (Sv _ h rs _) = foldMap (foldMap f) h <> foldMap f rs - -instance Traversable Sv where - traverse f (Sv s h rs e) = Sv s <$> traverse (traverse f) h <*> traverse f rs <*> pure e - --- | Determine the 'Headedness' of an 'Sv' -getHeadedness :: Sv s -> Headedness -getHeadedness = maybe Unheaded (const Headed) . _maybeHeader - --- | A 'Header' is present in many CSV documents, usually listing the names --- of the columns. We keep this separate from the regular records. -data Header s = - Header { - _headerRecord :: Record s - , _headerNewline :: Newline - } - deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) - -instance NFData s => NFData (Header s) - --- | Classy lenses for 'Header' -class HasHeader s t a b | s -> a, t -> b, s b -> t, t a -> s where - header :: Lens s t (Header a) (Header b) - headerNewline :: (s ~ t) => Lens s t Newline Newline - {-# INLINE headerNewline #-} - headerRecord :: Lens s t (Record a) (Record b) - {-# INLINE headerRecord #-} - default headerNewline :: (a ~ b) => Lens s t Newline Newline - headerNewline = header . headerNewline - headerRecord = header . headerRecord - -instance HasHeader (Header a) (Header b) a b where - header = id - {-# INLINE header #-} - headerNewline f (Header x1 x2) - = fmap (Header x1) (f x2) - {-# INLINE headerNewline #-} - headerRecord f (Header x1 x2) - = fmap (\y -> Header y x2) (f x1) - {-# INLINE headerRecord #-} - -instance HasRecord (Header a) (Header b) a b where - record = headerRecord - {-# INLINE record #-} - -instance HasFields (Header a) (Header b) a b where - fields = headerRecord . fields - --- | Used to build 'Sv's that don't have a header -noHeader :: Maybe (Header s) -noHeader = Nothing - --- | Convenience constructor for 'Header', usually when you're building 'Sv's -mkHeader :: Record s -> Newline -> Maybe (Header s) -mkHeader r n = Just (Header r n) - --- | Does the 'Sv' have a 'Header' or not? A header is a row at the beginning --- of a file which contains the string names of each of the columns. --- --- If a header is present, it must not be decoded with the rest of the data. -data Headedness = - Unheaded | Headed - deriving (Eq, Ord, Show) - --- | Classy lens for 'Headedness' -class HasHeadedness c where - headedness :: Lens' c Headedness - -instance HasHeadedness Headedness where - headedness = id - --- | By what are your values separated? The answer is often 'comma', but not always. --- --- A 'Separator' is just a 'Char'. It could be a sum type instead, since it --- will usually be comma or pipe, but our preference has been to be open here --- so that you can use whatever you'd like. There are test cases, for example, --- ensuring that you're free to use null-byte separated values if you so desire. -type Separator = Char - --- | Classy lens for 'Separator' -class HasSeparator c where - separator :: Lens' c Separator - -instance HasSeparator Char where - separator = id - {-# INLINE separator #-} - -instance HasSeparator (Sv s) where - separator f (Sv x1 x2 x3 x4) = - fmap (\y -> Sv y x2 x3 x4) (f x1) - {-# INLINE separator #-} - --- | The venerable comma separator. Used for CSV documents. -comma :: Separator -comma = ',' - --- | The pipe separator. Used for PSV documents. -pipe :: Separator -pipe = '|' - --- | Tab is a separator too - why not? -tab :: Separator -tab = '\t' diff --git a/src/Data/Vector/NonEmpty.hs b/src/Data/Vector/NonEmpty.hs deleted file mode 100644 --- a/src/Data/Vector/NonEmpty.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -{-| -Module : Data.Vector.NonEmpty -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable --} - -module Data.Vector.NonEmpty ( - NonEmptyVector (NonEmptyVector) -, fromNel -, toNel -, headNev -, tailNev -) where - -import Control.DeepSeq (NFData) -import Control.Lens (Lens', lens) -import Data.Functor.Apply (Apply((<.>))) -import Data.Foldable (toList) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Semigroup (Semigroup ((<>))) -import Data.Semigroup.Foldable (Foldable1 (foldMap1)) -import Data.Semigroup.Traversable (Traversable1 (traverse1)) -import Data.Vector (Vector) -import qualified Data.Vector as V -import GHC.Generics (Generic) - --- | A non-empty value of 'Vector' -data NonEmptyVector a = - NonEmptyVector a (Vector a) - deriving (Eq, Ord, Show, Generic) - -instance NFData a => NFData (NonEmptyVector a) where - --- | Convert a 'NonEmpty' list to a 'NonEmptyVector' -fromNel :: NonEmpty a -> NonEmptyVector a -fromNel (a :| as) = NonEmptyVector a (V.fromList as) - --- | Convert a 'NonEmptyVector' to a 'NonEmpty' list -toNel :: NonEmptyVector a -> NonEmpty a -toNel (NonEmptyVector a as) = a :| V.toList as - -instance Functor NonEmptyVector where - fmap f (NonEmptyVector a as) = NonEmptyVector (f a) (fmap f as) - -instance Apply NonEmptyVector where - (<.>) = (<*>) - -instance Applicative NonEmptyVector where - pure a = NonEmptyVector a V.empty - ff <*> fa = fromNel (toNel ff <*> toNel fa) - -instance Foldable NonEmptyVector where - foldMap f (NonEmptyVector a as) = f a `mappend` foldMap f as - -instance Foldable1 NonEmptyVector where - foldMap1 f (NonEmptyVector a as) = foldMap1 f (a :| toList as) - -instance Traversable NonEmptyVector where - traverse f (NonEmptyVector a as) = NonEmptyVector <$> f a <*> traverse f as - -instance Traversable1 NonEmptyVector where - traverse1 f = fmap fromNel . traverse1 f . toNel - -instance Semigroup (NonEmptyVector a) where - NonEmptyVector a as <> NonEmptyVector b bs = - NonEmptyVector a (V.concat [as, V.singleton b, bs]) - --- | Get or set the head of a 'NonEmptyVector' -headNev :: Lens' (NonEmptyVector a) a -headNev = lens (\(NonEmptyVector h _) -> h) (\(NonEmptyVector _ t) h -> NonEmptyVector h t) - --- | Get or set the head of a 'NonEmptyVector' -tailNev :: Lens' (NonEmptyVector a) (Vector a) -tailNev = lens (\(NonEmptyVector _ t) -> t) (\(NonEmptyVector h _) t -> NonEmptyVector h t) diff --git a/src/Text/Escape.hs b/src/Text/Escape.hs deleted file mode 100644 --- a/src/Text/Escape.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveGeneric #-} - -{-| -Module : Text.Escape -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -Quote characters can be escaped in CSV documents by using two quote characters -instead of one. sv's parser will unescape these sequences as it parses them, so -it wraps them in the newtype 'Unescaped' - -Encoding requires you to provide an 'Escaper', which is a function to escape -strings on the way out. --} - -module Text.Escape ( - Unescaped (Unescaped, getRawUnescaped) - , Escaper - , Escaper' - , escapeString - , escapeText - , escapeUtf8 - , escapeUtf8Lazy - , escapeChar -) where - -import Control.DeepSeq (NFData) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.UTF8 as UTF8 -import qualified Data.ByteString.Lazy.UTF8 as UTF8L -import Data.Foldable (Foldable) -import Data.Functor (Functor) -import Data.Monoid (Monoid) -import Data.Semigroup (Semigroup ((<>))) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Traversable (Traversable) -import GHC.Generics (Generic) - --- | Wrapper for text that is known to be in an unescaped form -newtype Unescaped a = - Unescaped { getRawUnescaped :: a } - deriving (Eq, Ord, Show, Semigroup, Monoid, Functor, Foldable, Traversable, Generic) - -instance NFData a => NFData (Unescaped a) - --- | A function that, given a char, escapes all occurrences of that char. --- --- This version allows the escaping to be type-changing. For example, escaping --- a single char can result in a string with two characters. -type Escaper s t = Char -> Unescaped s -> t - --- | A function that, given a char, escapes all occurrences of that char. -type Escaper' a = Char -> Unescaped a -> a - --- | Replaces all occurrences of the given character with two occurrences of that --- character, non-recursively, in the given 'String'. --- --- >>> escapeString ''' "hello 'string'" --- "hello ''string''" --- -escapeString :: Escaper' String -escapeString c = concatMap (doubleChar c) . getRawUnescaped - --- | Replaces all occurrences of the given character with two occurrences of that --- character in the given 'Text' --- --- @ --- {- LANGUAGE OverloadedStrings -} --- --- >>> escapeText ''' "hello 'text'" --- "hello ''text''" --- @ -escapeText :: Escaper' Text -escapeText c = - let ct = Text.singleton c - in Text.replace ct (ct <> ct) . getRawUnescaped - --- | Replaces all occurrences of the given character with two occurrences of that --- character in the given ByteString, which is assumed to be UTF-8 compatible. --- --- @ --- {- LANGUAGE OverloadedStrings -} --- >>> escapeUtf8 ''' "hello 'bytestring'" --- "hello ''bytestring''" --- @ -escapeUtf8 :: Escaper' B.ByteString -escapeUtf8 c = - UTF8.fromString . concatMap (doubleChar c) . UTF8.toString . getRawUnescaped - --- | Replaces all occurrences of the given character with two occurrences of that --- character in the given lazy ByteString, which is assumed to be UTF-8 compatible. --- --- @ --- {- LANGUAGE OverloadedStrings -} --- --- >>> escapeUtf8Lazy ''' "hello 'lazy bytestring'" --- "hello ''lazy bytestring''" --- @ -escapeUtf8Lazy :: Escaper' L.ByteString -escapeUtf8Lazy c = - UTF8L.fromString . concatMap (doubleChar c) . UTF8L.toString . getRawUnescaped - --- | Escape a character, which must return a string. --- --- >>> escapeChar ''' ''' --- "''" --- --- >>> escapeChar ''' 'z' --- "z" --- -escapeChar :: Escaper Char String -escapeChar c = doubleChar c . getRawUnescaped - -doubleChar :: Char -> Char -> String -doubleChar q z = if z == q then [q,q] else [z] diff --git a/src/Text/Newline.hs b/src/Text/Newline.hs deleted file mode 100644 --- a/src/Text/Newline.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{-| -Module : Text.Newline -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -A sum type for line endings --} - -module Text.Newline ( - Newline (CR, LF, CRLF) - , AsNewline(_Newline, _CR, _LF, _CRLF) - , newlineToString - , parseNewline -) where - -import Control.DeepSeq (NFData (rnf)) -import Control.Lens (Prism', prism, prism') -import Data.String (IsString (fromString)) -import Data.Text (Text) - --- | 'Newline' is a sum type for line endings -data Newline = - -- | > "\r" - CR - -- | > "\n" - | LF - -- | > "\rn" - | CRLF - deriving (Eq, Ord, Show) - -instance NFData Newline where - rnf x = seq x () - --- | 'AsNewline' is a classy prism for 'Newline' -class AsNewline r where - _Newline :: Prism' r Newline - _CR :: Prism' r () - _LF :: Prism' r () - _CRLF :: Prism' r () - _CR = _Newline . _CR - _LF = _Newline . _LF - _CRLF = _Newline . _CRLF - -instance AsNewline Newline where - _Newline = id - _CR = - prism (const CR) $ \x -> case x of - CR -> Right () - _ -> Left x - _LF = - prism (const LF) $ \x -> case x of - LF -> Right () - _ -> Left x - _CRLF = - prism (const CRLF) $ \x -> case x of - CRLF -> Right () - _ -> Left x - -instance AsNewline Text where - _Newline = prism' newlineToString parseNewline - --- | Convert a 'Newline' to a 'String'. Since this uses 'Data.String.IsString', --- it works for other data types, like 'Data.Text.Text' or --- 'Data.ByteString.ByteString'. -newlineToString :: IsString s => Newline -> s -newlineToString n = fromString $ - case n of - CR -> "\r" - LF -> "\n" - CRLF -> "\r\n" - --- | Try to parse text into a 'Newline' -parseNewline :: Text -> Maybe Newline -parseNewline "" = Nothing -parseNewline "\r" = Just CR -parseNewline "\n" = Just LF -parseNewline "\r\n" = Just CRLF -parseNewline _ = Nothing - diff --git a/src/Text/Quote.hs b/src/Text/Quote.hs deleted file mode 100644 --- a/src/Text/Quote.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -Module : Text.Quote -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -A sum type for quote characters --} - -module Text.Quote ( - Quote (SingleQuote, DoubleQuote) - , AsQuote (_Quote, _SingleQuote, _DoubleQuote) - , quoteChar - , quoteToString -) where - -import Control.DeepSeq (NFData (rnf)) -import Control.Lens (Prism', prism, prism', review) -import Data.String (IsString (fromString)) - --- | A sum type for quote characters. Either single or double quotes. -data Quote = - SingleQuote - | DoubleQuote - deriving (Eq, Ord, Show) - -instance NFData Quote where - rnf x = seq x () - --- | Classy prisms for 'Quote' -class AsQuote r where - _Quote :: Prism' r Quote - _SingleQuote :: Prism' r () - _DoubleQuote :: Prism' r () - _SingleQuote = _Quote . _SingleQuote - _DoubleQuote = _Quote . _DoubleQuote - -instance AsQuote Quote where - _Quote = id - _SingleQuote = prism (const SingleQuote) $ \x -> case x of - SingleQuote -> Right () - DoubleQuote -> Left x - _DoubleQuote = prism (const DoubleQuote) $ \x -> case x of - SingleQuote -> Left x - DoubleQuote -> Right () - -instance AsQuote Char where - _Quote = quoteChar - --- | Convert a Quote to the Char it represents. -quoteChar :: Prism' Char Quote -quoteChar = - prism' - (\q -> case q of - SingleQuote -> '\'' - DoubleQuote -> '"') - (\c -> case c of - '\'' -> Just SingleQuote - '"' -> Just DoubleQuote - _ -> Nothing) - --- | Convert a 'Quote' to a 'String'. Since this uses 'Data.String.IsString', --- it works for other data types, like 'Data.Text.Text' or --- 'Data.ByteString.ByteString'. -quoteToString :: IsString a => Quote -> a -quoteToString = fromString . pure . review quoteChar diff --git a/src/Text/Space.hs b/src/Text/Space.hs deleted file mode 100644 --- a/src/Text/Space.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DeriveGeneric #-} - -{-| -Module : Text.Space -Copyright : (C) CSIRO 2017-2018 -License : BSD3 -Maintainer : George Wilson -Stability : experimental -Portability : non-portable - -A sum type for space characters --} - -module Text.Space - ( HorizontalSpace (Space, Tab) - , AsHorizontalSpace (_HorizontalSpace, _Space, _Tab) - , Spaces - , single - , manySpaces - , tab - , spaceToChar - , charToSpace - , spacesText - , spacesString - , Spaced (Spaced, _before, _after, _value) - , HasSpaced (spaced, spacedValue, before, after) - , betwixt - , uniform - , unspaced - , removeSpaces - ) -where - -import Control.DeepSeq (NFData (rnf)) -import Control.Lens (Lens, Prism', prism, prism') -import Data.Semigroup (Semigroup ((<>))) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Vector as V -import GHC.Generics (Generic) - --- | 'HorizontalSpace' is a subset of 'Char'. To move back and forth betwen --- it and 'Char', 'String', or 'Data.Text.Text', use '_HorizontalSpace' -data HorizontalSpace = - Space - | Tab - deriving (Eq, Ord, Show) - -instance NFData HorizontalSpace where - rnf x = seq x () - --- | Classy prisms for 'HorizontalSpace's -class AsHorizontalSpace r where - _HorizontalSpace :: Prism' r HorizontalSpace - _Space :: Prism' r () - _Tab :: Prism' r () - _Space = _HorizontalSpace . _Space - _Tab = _HorizontalSpace . _Tab - -instance AsHorizontalSpace HorizontalSpace where - _HorizontalSpace = id - _Space = - prism (const Space) $ \x -> - case x of - Space -> Right () - _ -> Left x - _Tab = - prism (const Tab) $ \x -> - case x of - Tab -> Right () - _ -> Left x - -instance AsHorizontalSpace Char where - _HorizontalSpace = prism' spaceToChar charToSpace - --- | Helpful alias for lists of 'Space's -type Spaces = V.Vector HorizontalSpace - --- | One space -single :: Spaces -single = V.singleton Space - --- | As many spaces as you'd like -manySpaces :: Int -> Spaces -manySpaces = flip V.replicate Space - --- | One tab -tab :: Spaces -tab = V.singleton Tab - --- | Turn a 'Space' into a 'Char'. To go the other way, see 'charToSpace' -spaceToChar :: HorizontalSpace -> Char -spaceToChar Space = ' ' -spaceToChar Tab = '\t' - --- | Try to turn a 'Char' into a Space. To go the other way, see 'spaceToChar' -charToSpace :: Char -> Maybe HorizontalSpace -charToSpace c = case c of - ' ' -> Just Space - '\t' -> Just Tab - _ -> Nothing - --- | Parse 'Text' into 'Spaces', or turn spaces into 'Data.Text.Text' -spacesText :: Prism' Text Spaces -spacesText = - prism' - (Text.pack . foldMap (pure . spaceToChar)) - (fmap V.fromList . traverse charToSpace . Text.unpack) - --- | Parse 'String' into 'Spaces', or convert 'Spaces' into 'String' -spacesString :: Prism' String Spaces -spacesString = - prism' - (fmap spaceToChar . V.toList) - (fmap V.fromList . traverse charToSpace) - --- | 'Spaced' is a value with zero or many horizontal spaces around it on --- both sides. -data Spaced a = - Spaced { - _before :: Spaces - , _after :: Spaces - , _value :: a - } - deriving (Eq, Ord, Show, Generic) - -instance NFData a => NFData (Spaced a) - --- | Classy lenses for 'Spaced' -class HasSpaced s t a b | s -> a, t -> b, s b -> t, t a -> s where - spaced :: Lens s t (Spaced a) (Spaced b) - after :: (s ~ t) => Lens s t Spaces Spaces - {-# INLINE after #-} - before :: (s ~ t) => Lens s t Spaces Spaces - {-# INLINE before #-} - spacedValue :: Lens s t a b - {-# INLINE spacedValue #-} - default after :: (s ~ t, a ~ b) => Lens s t Spaces Spaces - after = spaced . after - default before :: (s ~ t, a ~ b) => Lens s t Spaces Spaces - before = spaced . before - default spacedValue :: (s ~ t, a ~ b) => Lens s t a b - spacedValue = spaced . spacedValue - -instance HasSpaced (Spaced a) (Spaced b) a b where - {-# INLINE after #-} - {-# INLINE before #-} - {-# INLINE spacedValue #-} - spaced = id - before f (Spaced x y z) = fmap (\w -> Spaced w y z) (f x) - spacedValue f (Spaced x y z) = fmap (Spaced x y) (f z) - after f (Spaced x y z) = fmap (\w -> Spaced x w z) (f y) - -instance Functor Spaced where - fmap f (Spaced b t a) = Spaced b t (f a) - --- | Appends the right parameter on the inside of the left parameter --- --- > Spaced " " () " " *> Spaced "\t\t\t" () "\t \t" == Spaced " \t\t\t" () "\t \t " -instance Applicative Spaced where - pure = unspaced - Spaced b t f <*> Spaced b' t' a = Spaced (b <> b') (t' <> t) (f a) - -instance Foldable Spaced where - foldMap f = f . _value - -instance Traversable Spaced where - traverse f (Spaced b t a) = fmap (Spaced b t) (f a) - --- | 'betwixt' is just the constructor for 'Spaced' with a different --- argument order, which is sometimes useful. -betwixt :: Spaces -> a -> Spaces -> Spaced a -betwixt b a t = Spaced b t a - --- | Places its argument in a 'Spaced' with no spaces. -unspaced :: a -> Spaced a -unspaced = uniform mempty - --- | 'uniform' puts the same spacing both before and after something. -uniform :: Spaces -> a -> Spaced a -uniform s a = Spaced s s a - --- | Remove spaces from the argument -removeSpaces :: Spaced a -> Spaced a -removeSpaces = unspaced . _value diff --git a/sv.cabal b/sv.cabal --- a/sv.cabal +++ b/sv.cabal @@ -1,5 +1,5 @@ name: sv -version: 0.1 +version: 1.0 license: BSD3 license-file: LICENCE author: George Wilson @@ -18,21 +18,17 @@ sv uses an Applicative combinator style for decoding and encoding, rather than a type class based approach. This means we can have multiple decoders for the same type, multiple combinators of the same type, and we never have - to worry about orphan instances. These decoders can be stiched together from + to worry about orphan instances. These decoders can be stitched together from provided primitives and combinators, or you can build one from a parser from your favourite parser combinator library. . + For parsing, sv uses , a high performance streaming CSV parser based on rank-select data structures. + sv works with UTF-8, and should work with CP-1252 as well. It does not work + with UTF-16 or UTF-32. + . sv returns values for all errors that occur - not just the first. Errors have more structure than just a string, indicating what went wrong. . - sv's parser is exposed so you can use it independently of the decoding, and - encoding and printing are similarly standalone. - . - sv focuses on correctness, on flexible and composable data types, - and on useful and informative error values. - Speed is also important to us, but it is not as important as these other - qualities. - . sv tries not to be opinionated about how your data should look. We intend for the user to have a great degree of freedom to build the right decoder for their dataset. @@ -51,9 +47,24 @@ * Encoding data to a CSV: * Handling NULL and Unknown occuring in a column of numbers: * Dealing with non-rectangular data: - * Handling multiple logical documents in one file: * Integrating with an existing attoparsec parser to read date stamps: - * Fixing inconsistent formatting with lenses: + . + To get the best performance, the hw-dsv parser and its dependencies + underlying sv should be compiled with the flag @+bmi2@ to enable . These + libraries are: @bits-extra@, @hw-rankselect@, @hw-rankselect-base@, and + @hw-dsv@. A simple way to set the flags for all of them when building with + cabal is to include a cabal.project file in your project containing + something like the following: + . + >packages: . + >package bits-extra + > flags: +bmi2 + >package hw-rankselect + > flags: +bmi2 + >package hw-rankselect-base + > flags: +bmi2 + >package hw-dsv + > flags: +bmi2 homepage: https://github.com/qfpl/sv bug-reports: https://github.com/qfpl/sv/issues @@ -63,7 +74,8 @@ tested-with: GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 - , GHC == 8.4.1 + , GHC == 8.4.3 + , GHC == 8.6.1 source-repository head type: git @@ -72,56 +84,26 @@ library exposed-modules: Data.Sv , Data.Sv.Decode - , Data.Sv.Decode.Error - , Data.Sv.Decode.Type , Data.Sv.Encode - , Data.Sv.Encode.Options - , Data.Sv.Encode.Type , Data.Sv.Parse - , Data.Sv.Parse.Internal - , Data.Sv.Parse.Options - , Data.Sv.Print - , Data.Sv.Print.Internal - , Data.Sv.Print.Options - , Data.Sv.Syntax - , Data.Sv.Syntax.Field - , Data.Sv.Syntax.Record - , Data.Sv.Syntax.Sv - , Data.Vector.NonEmpty - , Text.Escape - , Text.Newline - , Text.Quote - , Text.Space - -- other-modules: + , Data.Sv.Structure + other-modules: Data.Sv.Alien.Cassava -- other-extensions: - build-depends: ansi-wl-pprint >= 0.6.6 && < 0.7 + build-depends: base >=4.8 && <5 , attoparsec >= 0.12.1.4 && < 0.14 - , base >=4.8 && <5 , bifunctors >= 5.1 && < 6 , bytestring >= 0.9.1.10 && < 0.11 - , charset >=0.3 && <=0.4 - , containers >= 0.4 && < 0.6 - , contravariant >= 1.2 && < 1.5 - , deepseq >= 1.1 && < 1.5 - , lens >= 4 && < 5 - , mtl >= 2.0.1 && < 2.3 - , parsec >= 3.1 && < 3.2 - , parsers >=0.12 && <0.13 - , profunctors >= 5.2.1 && < 6 - , readable >= 0.3 && < 0.4 + , contravariant >= 1.2 && < 1.6 + , hw-dsv >= 0.2.1 && < 0.3 , semigroupoids >= 5 && <6 - , semigroups >= 0.18 && < 0.19 - , text >= 1.0 && < 1.3 + , sv-core >= 0.1 && < 0.2 , transformers >= 0.2 && < 0.6 - , trifecta >= 1.5 && < 1.8 , utf8-string >= 1 && < 1.1 , validation >= 1 && < 1.1 - , vector >= 0.10 && < 0.13 - , void >= 0.6 && < 1 hs-source-dirs: src default-language: Haskell2010 ghc-options: - -Wall + -Wall -O2 test-suite tasty type: @@ -129,30 +111,29 @@ main-is: tasty.hs other-modules: - Data.Sv.DecodeTest + Data.Sv.CassavaTest + , Data.Sv.DecodeTest , Data.Sv.EncodeTest - , Data.Sv.Generators - , Data.Sv.ParseTest - , Data.Sv.PrintTest - , Data.Sv.RoundTrips + , Data.Sv.RoundTripsDecodeEncode default-language: Haskell2010 build-depends: - ansi-wl-pprint >= 0.6.6 && < 0.7 - , base >=4.8 && <5 + base >=4.8 && <5 , bytestring >= 0.9.1.10 && < 0.11 - , contravariant >= 1.2 && < 1.5 - , hedgehog >= 0.5 && < 0.6 + , cassava >= 0.4.1 && < 0.6 + , contravariant >= 1.2 && < 1.6 + , hedgehog >= 0.5 && < 0.7 , lens >= 4 && < 5 , parsers >=0.12 && <0.13 + , Only >= 0.1 && < 0.2 , semigroupoids >= 5 && <6 , semigroups >= 0.18 && < 0.19 , sv - , tasty >= 0.11 && < 1.1 - , tasty-hedgehog >= 0.1 && < 0.2 + , tasty >= 0.11 && < 1.2 + , tasty-hedgehog >= 0.1 && < 0.3 , tasty-hunit >= 0.9 && < 0.11 , text >= 1.0 && < 1.3 - , trifecta >= 1.5 && < 1.8 + , trifecta >= 1.5 && < 2.1 , utf8-string >= 1 && < 1.1 , validation >= 1 && < 1.1 , vector >= 0.10 && < 0.13 diff --git a/test/Data/Sv/CassavaTest.hs b/test/Data/Sv/CassavaTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Sv/CassavaTest.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Sv.CassavaTest (test_CassavaAgreement) where + +import qualified Data.ByteString as BS +import qualified Data.Csv as Csv +import Data.Sv (Validation (Failure, Success), Headedness (Unheaded), ParseOptions (_headedness), defaultParseOptions) +import qualified Data.Sv as Sv (parseDecode) +import Data.Sv.Decode (Decode') +import qualified Data.Sv.Decode as Sv +import Data.Vector as V +import Data.Tuple.Only (Only (Only, fromOnly)) +import Hedgehog (Gen, (===), failure, forAll, property) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty (TestName, TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +test_CassavaAgreement :: TestTree +test_CassavaAgreement = + testGroup "cassava agreement" + [ cassavaAgreement "int" Sv.int (Gen.int (Range.linear (-10000000) 10000000)) + , cassavaAgreement "char" Sv.char (Gen.unicode) + , cassavaAgreement "integer" Sv.integer (Gen.integral (Range.linear (-10000000) 10000000)) + , cassavaAgreement "string" Sv.string (Gen.string (Range.linear 1 500) Gen.unicode) + , cassavaAgreement "bytestring" Sv.byteString (Gen.utf8 (Range.linear 1 500) Gen.unicode) + , cassavaAgreement "float" Sv.float (Gen.float (Range.exponentialFloat (-10000000) 10000000)) + , cassavaAgreement "double" Sv.double (Gen.double (Range.exponentialFloat (-10000000) 10000000)) + ] + +opts :: ParseOptions +opts = defaultParseOptions { _headedness = Unheaded } + +-- | Test that decoding with sv gets the same result as decoding with cassava +cassavaAgreement :: forall a . (Csv.FromField a, Csv.ToField a, Show a, Eq a) => TestName -> Decode' BS.ByteString a -> Gen a -> TestTree +cassavaAgreement name dec gen = testProperty name $ property $ do + a <- forAll gen + let oa = Only a + let sa = Csv.encode [oa] + let cassava :: Either String [a] + cassava = fmap fromOnly . V.toList <$> Csv.decode Csv.NoHeader sa + sv = Sv.parseDecode dec opts sa + case cassava of + Left _ -> failure + Right csa -> case sv of + Failure _ -> failure + Success sva -> do + csa === sva + sva === pure a diff --git a/test/Data/Sv/DecodeTest.hs b/test/Data/Sv/DecodeTest.hs --- a/test/Data/Sv/DecodeTest.hs +++ b/test/Data/Sv/DecodeTest.hs @@ -6,14 +6,18 @@ module Data.Sv.DecodeTest (test_Decode) where import Control.Applicative (liftA2) -import Control.Lens ((&), (.~)) -import Data.ByteString -import Data.Functor.Alt +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Char8 as BS8 +import Data.Functor.Alt (()) import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Semigroup +import Text.Read (readMaybe) +import Data.Semigroup (Semigroup) +import Data.Semigroupoid (Semigroupoid (o)) import qualified Data.Vector as V import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) +import Data.Text import Data.Sv import qualified Data.Sv.Decode as D @@ -23,30 +27,31 @@ testGroup "Decode" [ intOrStringTest , varyingLengthTest + , semigroupoidTest ] data IntOrString = I Int | S String deriving (Eq, Ord, Show) -intOrString :: Decode ByteString ByteString IntOrString +intOrString :: D.Decode' ByteString IntOrString intOrString = I <$> D.int S <$> D.string data V3 a = V3 a a a deriving (Eq, Ord, Show, Functor, Foldable, Traversable) -v3 :: Semigroup e => Decode e s a -> Decode e s (V3 a) +v3 :: Semigroup e => D.Decode e s a -> D.Decode e s (V3 a) v3 f = sequenceA (V3 f f f) -v3ios :: Decode ByteString ByteString (V3 IntOrString) +v3ios :: D.Decode ByteString ByteString (V3 IntOrString) v3ios = v3 intOrString -csv1 :: ByteString -csv1 = intercalate "\r\n" [ - "\"3\", \"4\", \"5\"" - , "\"quoted text\", unquoted text, 100" - , "7, unquoted text, 5" +csv1 :: LBS.ByteString +csv1 = LBS.intercalate "\n" [ + "\"3\",\"4\",\"5\"" + , "\"quoted text\",unquoted text,100" + , "7,unquoted text,5" ] csv1' :: [V3 IntOrString] @@ -56,16 +61,16 @@ , V3 (I 7) (S "unquoted text") (I 5) ] -opts :: ParseOptions ByteString -opts = defaultParseOptions & headedness .~ Unheaded +opts :: ParseOptions +opts = ParseOptions comma Unheaded intOrStringTest :: TestTree intOrStringTest = testCase "parse successfully" $ parseDecode v3ios opts csv1 @?= pure csv1' -varyingLength :: ByteString -varyingLength = intercalate "\r\n" [ +varyingLength :: LBS.ByteString +varyingLength = LBS.intercalate "\r\n" [ "one" , "one,two" , "one,two,three" @@ -73,15 +78,46 @@ , "one,two,three,four,five" ] -str2 :: Decode' ByteString (ByteString, ByteString) +str2 :: D.Decode' ByteString (ByteString, ByteString) str2 = liftA2 (,) D.contents D.contents varyingLengthTest :: TestTree varyingLengthTest = testCase "varyingLength has all the right errors" $ parseDecode str2 opts varyingLength @?= - Failure (DecodeErrors (D.UnexpectedEndOfRow :| [ - D.ExpectedEndOfRow (V.fromList $ fmap pure [Unquoted "three"]) - , D.ExpectedEndOfRow (V.fromList $ fmap pure [Unquoted "three", Unquoted "four"]) - , D.ExpectedEndOfRow (V.fromList $ fmap pure [Unquoted "three", Unquoted "four", Unquoted "five"]) + Failure (DecodeErrors (UnexpectedEndOfRow :| [ + ExpectedEndOfRow (V.fromList ["three"]) + , ExpectedEndOfRow (V.fromList ["three", "four"]) + , ExpectedEndOfRow (V.fromList ["three", "four", "five"]) ])) + +semiTestString1 :: LBS.ByteString +semiTestString1 = "hello,5,6.6,goodbye" + +semiTestString2 :: LBS.ByteString +semiTestString2 = "hello,no,6.6,goodbye" + +semiTestString3 :: LBS.ByteString +semiTestString3 = "hello,5,false,goodbye" + +parseDecoder :: D.Decode' ByteString Int +parseDecoder = D.contents D.>>== + \bs -> validateMaybe (D.BadDecode bs) . readMaybe . BS8.unpack $ bs + +data Semi = Semi Text Int Double Text deriving (Eq, Show) + +semiD :: D.Decode' ByteString Semi +semiD = Semi <$> D.utf8 <*> (parseDecoder `o` D.contents) <*> D.double <*> D.utf8 + +semigroupoidTest :: TestTree +semigroupoidTest = testGroup "Semigroupoid Decode" + [ testCase "Does the right thing in the case of success" $ + parseDecode semiD opts semiTestString1 @?= + pure [Semi "hello" 5 6.6 "goodbye"] + , testCase "Does the right thing in the case of left failure" $ + parseDecode semiD opts semiTestString2 @?= + Failure (DecodeErrors (pure (BadDecode "no"))) + , testCase "Does the right thing in the case of right failure" $ + parseDecode semiD opts semiTestString3 @?= + Failure (DecodeErrors (pure (BadDecode "Couldn't parse \"false\" as a double"))) + ] diff --git a/test/Data/Sv/EncodeTest.hs b/test/Data/Sv/EncodeTest.hs --- a/test/Data/Sv/EncodeTest.hs +++ b/test/Data/Sv/EncodeTest.hs @@ -49,9 +49,9 @@ decidableTests = testGroup "decidable" [ testCase "encode an Int" $ - encodeRow intOrString opts i @?= "\"5\"" + encodeRow intOrString opts i @?= "5" , testCase "encode a String" $ - encodeRow intOrString opts s @?= "\"hello\"" + encodeRow intOrString opts s @?= "hello" ] intEmptyAndString :: Encode IntAndString @@ -64,16 +64,16 @@ divisibleTests = testGroup "divisible" [ testCase "encode an IntAndString" $ - encodeRow intAndString opts ias @?= "\"10\",\"goodbye\"" + encodeRow intAndString opts ias @?= "10,goodbye" , testCase "encode an IntAndString with an empty between" $ - encodeRow intEmptyAndString opts ias @?= "\"10\",\"\",\"goodbye\"" + encodeRow intEmptyAndString opts ias @?= "10,,goodbye" ] encodeTests :: TestTree encodeTests = testCase "multiple lines" $ encode (divided intAndString intOrString) opts [(IAS 3 "book", I 4), (IAS 7 "film", S "ok")] - @?= "\"3\",\"book\",\"4\"\r\n\"7\",\"film\",\"ok\"" + @?= "3,book,4\n7,film,ok" escapeTests :: TestTree escapeTests = diff --git a/test/Data/Sv/Generators.hs b/test/Data/Sv/Generators.hs deleted file mode 100644 --- a/test/Data/Sv/Generators.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Sv.Generators ( - genSv - , genSvWithHeadedness - , genNewline - , genSep - , genQuote - , genSpaced - , genField - , genSpacedField - , genRecord - , genRecords - , genHeader - , genCsvString -) where - -import Control.Applicative ((<$>), liftA2, liftA3) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LBS -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as Builder -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Semigroup (Semigroup ((<>))) -import qualified Data.Vector as V -import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range - -import Data.Sv.Syntax.Sv (Sv (Sv), Header (Header), Headedness, getHeadedness, Separator) -import Data.Sv.Syntax.Field (Field (Quoted, Unquoted)) -import Data.Sv.Syntax.Record (Record, Records (EmptyRecords, Records), recordNel) -import Text.Escape (Unescaped (Unescaped)) -import Text.Newline (Newline (CRLF, LF)) -import Text.Space (Spaces, Spaced (Spaced)) -import Text.Quote (Quote (SingleQuote, DoubleQuote)) - -genSv :: Gen Separator -> Gen Spaces -> Gen s -> Gen (Sv s) -genSv sep spc s = - let rs = genRecords spc s - e = Gen.list (Range.linear 0 5) genNewline - h = Gen.maybe (genHeader spc s genNewline) - in Sv <$> sep <*> h <*> rs <*> e - -genSvWithHeadedness :: Gen Separator -> Gen Spaces -> Gen s -> Gen (Sv s, Headedness) -genSvWithHeadedness sep spc s = fmap (\c -> (c, getHeadedness c)) (genSv sep spc s) - -genNewline :: Gen Newline -genNewline = - -- TODO put CR back in - Gen.element [CRLF, LF] - -genSep :: Gen Separator -genSep = - Gen.element ['|', ',', '\t', '\x1F4A9'] - -genSpaced :: Gen Spaces -> Gen s -> Gen (Spaced s) -genSpaced spc str = - liftA3 Spaced spc spc str - -genQuote :: Gen Quote -genQuote = - Gen.element [SingleQuote, DoubleQuote] - -genUnescaped :: Gen a -> Gen (Unescaped a) -genUnescaped = fmap Unescaped - -genField :: Gen s -> Gen (Field s) -genField s = - Gen.choice [ - Unquoted <$> s - , liftA2 Quoted genQuote (genUnescaped s) - ] - -genSpacedField :: Gen Spaces -> Gen s -> Gen (Spaced (Field s)) -genSpacedField spc s = genSpaced spc (genField s) - -genRecord :: Gen Spaces -> Gen s -> Gen (Record s) -genRecord spc s = - recordNel <$> Gen.nonEmpty (Range.linear 1 10) (genSpacedField spc s) - -genHeader :: Gen Spaces -> Gen s -> Gen Newline -> Gen (Header s) -genHeader spc s n = - Header <$> genRecord spc s <*> n - -genRecords :: Gen Spaces -> Gen s -> Gen (Records s) -genRecords spc s = - let rec = genRecord spc s - nlr = liftA2 (,) genNewline rec - in maybe EmptyRecords (uncurry Records) <$> - Gen.maybe ( - liftA2 (,) - rec - (V.fromList <$> Gen.list (Range.linear 0 1000) nlr) - ) - -genCsvString :: Gen ByteString -genCsvString = - let intercalate' :: (Semigroup m, Monoid m) => m -> NonEmpty m -> m - intercalate' _ (x:|[]) = x - intercalate' m (x:|y:zs) = x <> m <> intercalate' m (y:|zs) - genNewlineString :: Gen Builder - genNewlineString = Gen.element (fmap Builder.string7 ["\n", "\r", "\r\n"]) - genCsvRowString = intercalate' "," <$> Gen.nonEmpty (Range.linear 1 100) genCsvField - enquote c s = fmap (\z -> c <> z <> c) s - genCsvFieldString :: Gen Builder - genCsvFieldString = Builder.byteString <$> - Gen.utf8 (Range.linear 1 50) (Gen.filter (`notElem` [',','"','\'','\n','\r']) Gen.unicode) - genCsvField = - Gen.choice [ - enquote "\"" genCsvFieldString - , enquote "'" genCsvFieldString - , genCsvFieldString - ] - in fmap (LBS.toStrict . Builder.toLazyByteString) $ intercalate' <$> genNewlineString <*> Gen.nonEmpty (Range.linear 0 100) genCsvRowString diff --git a/test/Data/Sv/ParseTest.hs b/test/Data/Sv/ParseTest.hs deleted file mode 100644 --- a/test/Data/Sv/ParseTest.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Sv.ParseTest (test_Parse) where - -import Control.Lens ((&), (.~)) -import Data.ByteString (ByteString) -import qualified Data.ByteString.UTF8 as UTF8 -import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) -import Data.Either (isLeft) -import Data.Foldable (fold) -import Data.Semigroup (Semigroup ((<>))) -import Data.Text (Text, pack) -import Hedgehog -import Test.Tasty (TestName, TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) -import Test.Tasty.HUnit (Assertion, assertBool, testCase, (@?=)) -import Text.Newline (Newline (CR, LF, CRLF), newlineToString) -import Text.Parser.Char (CharParsing) -import Text.Trifecta (Result (Success, Failure), parseByteString, _errDoc) - -import Data.Sv.Generators (genCsvString) -import Data.Sv.Parse (ParseOptions, defaultParseOptions, headedness, separator, encodeString) -import Data.Sv.Parse.Internal (doubleQuotedField, record, separatedValues, singleQuotedField, spaced, spacedField) -import Data.Sv.Syntax.Sv (Sv, mkSv, comma, pipe, tab, Headedness (Unheaded), Separator) -import Data.Sv.Syntax.Field (Field (Quoted, Unquoted), SpacedField) -import Data.Sv.Syntax.Record (Record (Record), recordNel, mkRecords, Records (EmptyRecords)) -import Text.Escape (Unescaped (Unescaped)) -import Text.Space (Spaced (Spaced), manySpaces, unspaced) -import Text.Quote (Quote (SingleQuote, DoubleQuote), quoteToString) - -test_Parse :: TestTree -test_Parse = - testGroup "Parse" [ - singleQuotedFieldTest - , doubleQuotedFieldTest - , fieldTest - , recordTest - , csvTest - , psvTest - , tsvTest - , nsvTest - , crsvTest - , bssvTest - , randomCsvTest - ] - -r2e :: Result a -> Either String a -r2e r = case r of - Success a -> Right a - Failure e -> Left (show (_errDoc e)) - -(@?=/) :: - (Show a, Show b, Eq a, Eq b) - => Either a b - -> b - -> Assertion -(@?=/) l r = l @?= pure r - -qd, qs :: a -> Field a -qd = Quoted DoubleQuote . Unescaped -qs = Quoted SingleQuote . Unescaped -qsr :: s -> Record s -qsr = Record . pure . nospc . qs -uq :: s -> SpacedField s -uq = unspaced . Unquoted -uqa :: NonEmpty s -> Record s -uqa = recordNel . fmap uq -uqaa :: [NonEmpty s] -> [Record s] -uqaa = fmap uqa -nospc :: Field s -> SpacedField s -nospc = unspaced - -quotedFieldTest :: (forall m . CharParsing m => m (SpacedField Text)) -> TestName -> Quote -> TestTree -quotedFieldTest parser name quote = - let p :: [ByteString] -> Either String (SpacedField Text) - p = r2e . parseByteString parser mempty . mconcat - q = quoteToString quote - qq = Quoted quote . Unescaped - in testGroup name [ - testCase "empty" $ - p [q,q] @?=/ nospc (qq "") - , testCase "text" $ - p [q,"hello text",q] - @?=/ nospc (qq "hello text") - , testCase "capture space" $ - p [" ", q, " spaced text ", q, " "] - @?=/ Spaced (manySpaces 3) (manySpaces 5) (qq " spaced text ") - , testCase "no closing quote" $ - assertBool "wasn't left" (isLeft (p [q, "no closing quote" ])) - , testCase "no opening quote" $ - assertBool "wasn't left" (isLeft (p [ "no opening quote", q])) - , testCase "no quotes" $ - assertBool "wasn't left" (isLeft (p [ "no quotes" ])) - , testCase "quoted field can handle escaped quotes" $ - p [q,"yes", q, q, "no", q] @?=/ nospc (Quoted quote (Unescaped ("yes" <> quoteToString quote <> "no"))) - ] - -singleQuotedFieldTest, doubleQuotedFieldTest :: TestTree -singleQuotedFieldTest = quotedFieldTest (spaced comma (singleQuotedField pack)) "singleQuotedField" SingleQuote -doubleQuotedFieldTest = quotedFieldTest (spaced comma (doubleQuotedField pack)) "doubleQuotedField" DoubleQuote - -fieldTest :: TestTree -fieldTest = - let p :: ByteString -> Either String (SpacedField Text) - p = r2e . parseByteString (spacedField comma pack) mempty - in testGroup "field" [ - testCase "doublequoted" $ - p "\"hello\"" @?=/ nospc (qd "hello") - , testCase "singlequoted" $ - p "'goodbye'" @?=/ nospc (qs "goodbye") - , testCase "unquoted" $ - p "yes" @?=/ uq "yes" - , testCase "spaced doublequoted" $ - p " \" spaces \" " @?=/ Spaced (manySpaces 7) (manySpaces 4) (qd " spaces ") - , testCase "spaced singlequoted" $ - p " ' more spaces ' " @?=/ Spaced (manySpaces 8) (manySpaces 1) (qs " more spaces ") - , testCase "spaced unquoted" $ - p " some text " @?=/ Spaced (manySpaces 2) (manySpaces 3) (Unquoted "some text") - , testCase "fields can include the separator in single quotes" $ - p "'hello,there,'" @?=/ nospc (qs "hello,there,") - , testCase "fields can include the separator in double quotes" $ - p "\"court,of,the,,,,crimson,king\"" @?=/ nospc (qd "court,of,the,,,,crimson,king") - , testCase "unquoted fields stop at the separator (1)" $ - p "close,to,the,edge" @?=/ uq "close" - , testCase "unquoted fields stop at the separator (2)" $ - p ",close,to,the,edge" @?=/ uq "" - ] - -recordTest :: TestTree -recordTest = - let opts :: ParseOptions Text - opts = defaultParseOptions & encodeString .~ pack - p :: ByteString -> Either String (Record Text) - p = r2e . parseByteString (record opts) mempty - in testGroup "record" [ - testCase "single field" $ - p "Yes" @?=/ uqa (pure "Yes") - , testCase "fields" $ - p "Anderson,Squire,Wakeman,Howe,Bruford" @?=/ uqa ("Anderson":|["Squire", "Wakeman", "Howe", "Bruford"]) - , testCase "commas" $ - p ",,," @?=/ uqa ("":|["","",""]) - , testCase "record ends at newline" $ - p "a,b,c\nd,e,f" @?=/ uqa ("a":|["b","c"]) - , testCase "record ends at carriage return" $ - p "g,h,i\rj,k,l" @?=/ uqa ("g":|["h","i"]) - , testCase "record ends at carriage return followed by newline" $ - p "m,n,o\r\np,q,r" @?=/ uqa ("m":|["n","o"]) - ] - -separatedValuesTest :: Separator -> Newline -> Int -> TestTree -separatedValuesTest sep nl newlines = - let opts = defaultParseOptions & separator .~ sep & headedness .~ Unheaded & encodeString .~ pack - p :: ByteString -> Either String (Sv Text) - p = r2e . parseByteString (separatedValues opts) mempty - ps = p . fold - mkSv' :: [Record s] -> [Newline] -> Sv s - mkSv' rs e = mkSv sep Nothing e $ maybe EmptyRecords (mkRecords nl) $ nonEmpty rs - s = UTF8.fromString [sep] - nls = newlineToString nl - terminator = replicate newlines nl - termStr = foldMap newlineToString terminator - in testGroup "separatedValues" [ - testCase "empty" $ - ps ["", termStr] @?=/ mkSv' [] terminator - , testCase "single empty quotes field" $ - ps ["''", termStr] @?=/ mkSv' [qsr ""] terminator - , testCase "single field, single record" $ - ps ["one", termStr] @?=/ mkSv' [uqa (pure "one")] terminator - , testCase "single field, multiple records" $ - ps ["one",nls,"un",termStr] @?=/ mkSv' [uqa (pure "one"), uqa (pure "un")] terminator - , testCase "multiple fields, single record" $ - ps ["one", s, "two",termStr] @?=/ mkSv' (uqaa (pure ("one":|["two"]))) terminator - , testCase "multiple fields, multiple records" $ - ps ["one", s, "two", s, "three", nls, "un", s, "deux", s, "trois",termStr] - @?=/ mkSv' (uqaa ["one":|["two", "three"] , "un":|["deux", "trois"]]) terminator - ] - -svTest :: String -> Separator -> TestTree -svTest name sep = - testGroup name $ separatedValuesTest sep <$> [CR, LF, CRLF] <*> [0,1,2] - -csvTest :: TestTree -csvTest = svTest "csv" comma - -psvTest :: TestTree -psvTest = svTest "psv" pipe - -tsvTest :: TestTree -tsvTest = svTest "tsv" tab - -nsvTest :: TestTree -nsvTest = svTest "NULL separated values" '\0' - -crsvTest :: TestTree -crsvTest = - testGroup "carriage return separated values" $ - separatedValuesTest '\r' <$> [LF] <*> [0,1,2] - -bssvTest :: TestTree -bssvTest = svTest "backspace separated values" '\BS' - -prop_randomCsvTest :: Property -prop_randomCsvTest = property $ do - str <- forAll genCsvString - let opts = separatedValues (defaultParseOptions & headedness .~ Unheaded & encodeString .~ id) - x :: Either String (Sv String) - x = r2e (parseByteString opts mempty str) - case x of - Left _ -> failure - Right _ -> success - -randomCsvTest :: TestTree -randomCsvTest = - testProperty "parse random CSV" prop_randomCsvTest diff --git a/test/Data/Sv/PrintTest.hs b/test/Data/Sv/PrintTest.hs deleted file mode 100644 --- a/test/Data/Sv/PrintTest.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Sv.PrintTest (test_Print) where - -import Data.ByteString (ByteString) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit ((@?=), testCase) - -import Data.Sv.Print (printSv) -import Data.Sv.Syntax.Field (Field (Quoted)) -import Data.Sv.Syntax.Record (Records (EmptyRecords), singleField, singleRecord) -import Data.Sv.Syntax.Sv (Sv (Sv), noHeader, comma) -import Text.Quote (Quote (SingleQuote)) - -test_Print :: TestTree -test_Print = - testGroup "Print" [ - csvPrint - ] - -csvPrint :: TestTree -csvPrint = - testGroup "csvPrint" [ - testCase "empty" $ - let subject :: Sv ByteString - subject = Sv comma noHeader EmptyRecords [] - in printSv subject @?= "" - , testCase "empty quotes" $ - let subject :: Sv ByteString - subject = Sv comma noHeader (singleRecord (singleField (Quoted SingleQuote mempty))) [] - in printSv subject @?= ("''" :: ByteString) - ] diff --git a/test/Data/Sv/RoundTrips.hs b/test/Data/Sv/RoundTrips.hs deleted file mode 100644 --- a/test/Data/Sv/RoundTrips.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module Data.Sv.RoundTrips (test_Roundtrips) where - -import Control.Lens ((&), (.~)) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.UTF8 as UTF8 -import Data.Semigroup ((<>)) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Vector as V -import Hedgehog ((===), Property, Gen, forAll, property) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import Test.Tasty (TestName, TestTree, testGroup) -import Test.Tasty.Hedgehog (testProperty) -import Test.Tasty.HUnit ((@?=), testCase) -import Text.Parser.Char (CharParsing) -import Text.Trifecta (parseByteString) - -import Data.Sv -import qualified Data.Sv.Decode as D -import qualified Data.Sv.Encode as E -import Data.Sv.Decode.Error (trifectaResultToEither) -import Data.Sv.Generators -import Data.Sv.Syntax (Sv, Headedness, SpacedField, comma) -import Data.Sv.Parse (defaultParseOptions, headedness, encodeString, separatedValues) -import Data.Sv.Parse.Internal (spacedField) -import Data.Sv.Print (defaultPrintOptions, printSvText) -import Data.Sv.Print.Internal (printSpaced) -import Text.Space (HorizontalSpace (Space, Tab), Spaces) - -test_Roundtrips :: TestTree -test_Roundtrips = - testGroup "Round trips" [ - csvRoundTrip - , fieldRoundTrip - , testGroup "decode/encode isomorphisms" [ - bool - , char - , int - , integer - , float - , double - , string - , byteString - , lazyByteString - , text - ] - , testGroup "decode/encode normalising" [ - boolSI - , floatSI - , doubleSI - ] - - ] - -printAfterParseRoundTrip :: (forall m. CharParsing m => m a) -> (a -> ByteString) -> TestName -> ByteString -> TestTree -printAfterParseRoundTrip parser display name s = - testCase name $ - fmap display (trifectaResultToEither $ parseByteString parser mempty s) @?= Right s - -fieldRoundTrip :: TestTree -fieldRoundTrip = - let sep = comma - test = - printAfterParseRoundTrip - (spacedField sep UTF8.fromString :: CharParsing m => m (SpacedField ByteString)) - (BL.toStrict . Builder.toLazyByteString . printSpaced defaultPrintOptions) - in testGroup "field" [ - test "empty" "" - , test "unquoted" "wobble" - , test "unquoted with space" " wiggle " - , test "single quoted" "'tortoise'" - , test "single quoted with space" " 'turtle' " - , test "single quoted with escape outer" "\'\'\'c\'\'\'" - , test "single quoted with escape in the middle" "\' The char \'\'c\'\' is nice.\'" - , test "double quoted" "\"honey badger\"" - , test "double quoted with space" " \" sun bear\" " - , test "double quoted with escape outer" "\"\"\"laser\"\"\"" - , test "double quoted with escape in the middle" "\"John \"\"The Duke\"\" Wayne\"" - ] - -csvRoundTrip :: TestTree -csvRoundTrip = testProperty "roundtrip" prop_csvRoundTrip - -prop_csvRoundTrip :: Property -prop_csvRoundTrip = - let genSpace :: Gen HorizontalSpace - genSpace = Gen.element [Space, Tab] - genSpaces :: Gen Spaces - genSpaces = V.fromList <$> Gen.list (Range.linear 0 10) genSpace - genText :: Gen Text - genText = Gen.text (Range.linear 1 100) Gen.alphaNum - gen = genSvWithHeadedness (pure comma) genSpaces genText - mkOpts h = defaultParseOptions & headedness .~ h & encodeString .~ Text.pack - parseCsv :: CharParsing m => Headedness -> m (Sv Text) - parseCsv = separatedValues . mkOpts - parse h = parseByteString (parseCsv h) mempty - in property $ do - (c,h) <- forAll gen - trifectaResultToEither (fmap printSvText (parse h (printSvText c))) === pure (printSvText c) - -encOpts :: EncodeOptions -encOpts = defaultEncodeOptions & quote .~ Nothing - -parOpts :: ParseOptions ByteString -parOpts = defaultParseOptions & headedness .~ Unheaded - --- Round-trips an encode/decode pair. This version checks whether the pair --- form an isomorphism -roundTripCodecIso :: (Eq a, Show a) => TestName -> Decode' ByteString a -> Encode a -> [(ByteString, a)] -> TestTree -roundTripCodecIso name dec enc bsas = testGroup name . flip foldMap bsas $ \(bs,a) -> - [ testCase (UTF8.toString bs <> ": encode . decode") $ - Success (BL.fromStrict bs) @?= (encode enc encOpts <$> parseDecode dec parOpts bs) - , testCase (UTF8.toString bs <> ": decode . encode") $ - Success [a] @?= (parseDecode dec parOpts $ BL.toStrict $ encodeRow enc encOpts a) - ] - --- Round-trips an encode/decode pair. This version checks whether the pair --- form a split-idempotent. That is to say, one direction is identity, the other is --- idempotent. -roundTripCodecSplitIdempotent :: (Eq a, Show a) => TestName -> Decode' ByteString a -> Encode a -> [(ByteString, a)] -> TestTree -roundTripCodecSplitIdempotent name dec enc bsas = - let deco = parseDecode dec parOpts - enco = encode enc encOpts - encdec = fmap enco . deco - in testGroup name . flip foldMap bsas $ \(bs,a) -> - [ testCase (UTF8.toString bs <> ": decode . encode . decode") $ - Success (Success [a]) @?= (deco . BL.toStrict <$> encdec bs) - , testCase (UTF8.toString bs <> ": decode . encode") $ - Success [a] @?= (parseDecode dec parOpts $ BL.toStrict $ enco [a]) - ] - -byteString :: TestTree -byteString = roundTripCodecIso "bytestring" D.contents E.byteString - [ ("hello","hello")] - -lazyByteString :: TestTree -lazyByteString = roundTripCodecIso "lazy bytestring" D.lazyByteString E.lazyByteString [("hello","hello")] - -bool :: TestTree -bool = roundTripCodecIso "bool" D.boolean E.booltruefalse [("true", True), ("false", False)] - -char :: TestTree -char = roundTripCodecIso "char" D.char E.char [(UTF8.fromString "c", 'c'), (UTF8.fromString "💩", '💩')] - -string :: TestTree -string = roundTripCodecIso "string" D.string E.string [(UTF8.fromString "hello", "hello"), (UTF8.fromString "💩💩💩💩", "💩💩💩💩")] - -int :: TestTree -int = roundTripCodecIso "int" D.int E.int [("5", 5)] - -integer :: TestTree -integer = roundTripCodecIso "integer" D.integer E.integer - [ ("5", 5) - , ("1000000", 1000000) - ] - -float :: TestTree -float = roundTripCodecIso "float" D.float E.float - [ ("5.0", 5) - , ("10.5", 10.5) - , ("12345.678", 12345.678) - ] - -double :: TestTree -double = roundTripCodecIso "double" D.double E.double [("5.0", 5)] - -text :: TestTree -text = roundTripCodecIso "text" D.utf8 E.text [(UTF8.fromString "hello", "hello"), (UTF8.fromString "💩💩💩💩", "💩💩💩💩")] - -boolSI :: TestTree -boolSI = roundTripCodecSplitIdempotent "bool" D.boolean E.bool10 - [ ("1", True) - , ("0", False) - ] - -floatSI :: TestTree -floatSI = roundTripCodecSplitIdempotent "float" D.float E.float - [ ("5", 5) - ] - -doubleSI :: TestTree -doubleSI = roundTripCodecSplitIdempotent "double" D.double E.double - [ ("5", 5) - ] diff --git a/test/Data/Sv/RoundTripsDecodeEncode.hs b/test/Data/Sv/RoundTripsDecodeEncode.hs new file mode 100644 --- /dev/null +++ b/test/Data/Sv/RoundTripsDecodeEncode.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Data.Sv.RoundTripsDecodeEncode (test_Roundtrips) where + +import Control.Lens ((&), (.~)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.UTF8 as UTF8 +import Data.Semigroup ((<>)) +import Test.Tasty (TestName, TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +import Data.Sv +import qualified Data.Sv.Decode as D +import qualified Data.Sv.Encode as E + +test_Roundtrips :: TestTree +test_Roundtrips = + testGroup "Round trips" [ + testGroup "decode/encode isomorphisms" [ + bool + , char + , int + , integer + , float + , double + , string + , byteString + , lazyByteString + , text + ] + , testGroup "decode/encode normalising" [ + boolSI + , floatSI + , doubleSI + ] + + ] + +encOpts :: EncodeOptions +encOpts = defaultEncodeOptions & quoting .~ Never + +parOpts :: ParseOptions +parOpts = defaultParseOptions & headedness .~ Unheaded + +lbUtf8 :: LBS.ByteString -> String +lbUtf8 = UTF8.toString . LBS.toStrict + +utf8lb :: String -> LBS.ByteString +utf8lb = LBS.fromStrict . UTF8.fromString + +-- Round-trips an encode/decode pair. This version checks whether the pair +-- form an isomorphism +roundTripCodecIso :: (Eq a, Show a) => TestName -> Decode' ByteString a -> Encode a -> [(LBS.ByteString, a)] -> TestTree +roundTripCodecIso name dec enc bsas = testGroup name . flip foldMap bsas $ \(bs,a) -> + [ testCase (lbUtf8 bs <> ": encode . decode") $ + Success bs @?= (encode enc encOpts <$> parseDecode dec parOpts bs) + , testCase (lbUtf8 bs <> ": decode . encode") $ + Success [a] @?= (parseDecode dec parOpts $ encodeRow enc encOpts a) + ] + +-- Round-trips an encode/decode pair. This version checks whether the pair +-- form a split-idempotent. That is to say, one direction is identity, the other is +-- idempotent. +roundTripCodecSplitIdempotent :: (Eq a, Show a) => TestName -> Decode' ByteString a -> Encode a -> [(LBS.ByteString, a)] -> TestTree +roundTripCodecSplitIdempotent name dec enc bsas = + let deco = parseDecode dec parOpts + enco = encode enc encOpts + encdec = fmap enco . deco + in testGroup name . flip foldMap bsas $ \(bs,a) -> + [ testCase (lbUtf8 bs <> ": decode . encode . decode") $ + Success (Success [a]) @?= (deco <$> encdec bs) + , testCase (lbUtf8 bs <> ": decode . encode") $ + Success [a] @?= (parseDecode dec parOpts $ enco [a]) + ] + +byteString :: TestTree +byteString = roundTripCodecIso "bytestring" D.contents E.byteString + [ ("hello","hello")] + +lazyByteString :: TestTree +lazyByteString = roundTripCodecIso "lazy bytestring" D.lazyByteString E.lazyByteString [("hello","hello")] + +bool :: TestTree +bool = roundTripCodecIso "bool" D.boolean E.booltruefalse [("true", True), ("false", False)] + +char :: TestTree +char = roundTripCodecIso "char" D.char E.char [(utf8lb "c", 'c'), (utf8lb "💩", '💩')] + +string :: TestTree +string = roundTripCodecIso "string" D.string E.string [(utf8lb "hello", "hello"), (utf8lb "💩💩💩💩", "💩💩💩💩")] + +int :: TestTree +int = roundTripCodecIso "int" D.int E.int [("5", 5)] + +integer :: TestTree +integer = roundTripCodecIso "integer" D.integer E.integer + [ ("5", 5) + , ("1000000", 1000000) + ] + +float :: TestTree +float = roundTripCodecIso "float" D.float E.float + [ ("5.0", 5) + , ("10.5", 10.5) + , ("12345.678", 12345.678) + ] + +double :: TestTree +double = roundTripCodecIso "double" D.double E.double [("5.0", 5)] + +text :: TestTree +text = roundTripCodecIso "text" D.utf8 E.text [(utf8lb "hello", "hello"), (utf8lb "💩💩💩💩", "💩💩💩💩")] + +boolSI :: TestTree +boolSI = roundTripCodecSplitIdempotent "bool" D.boolean E.bool10 + [ ("1", True) + , ("0", False) + ] + +floatSI :: TestTree +floatSI = roundTripCodecSplitIdempotent "float" D.float E.float + [ ("5", 5) + ] + +doubleSI :: TestTree +doubleSI = roundTripCodecSplitIdempotent "double" D.double E.double + [ ("5", 5) + ] diff --git a/test/tasty.hs b/test/tasty.hs --- a/test/tasty.hs +++ b/test/tasty.hs @@ -2,18 +2,16 @@ import Test.Tasty (defaultMain, testGroup) +import Data.Sv.CassavaTest (test_CassavaAgreement) import Data.Sv.DecodeTest (test_Decode) import Data.Sv.EncodeTest (test_Encode) -import Data.Sv.ParseTest (test_Parse) -import Data.Sv.PrintTest (test_Print) -import Data.Sv.RoundTrips (test_Roundtrips) +import Data.Sv.RoundTripsDecodeEncode (test_Roundtrips) main :: IO () main = defaultMain $ testGroup "Tests" [ - test_Parse - , test_Print - , test_Decode + test_Decode , test_Encode , test_Roundtrips + , test_CassavaAgreement ]