diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,31 @@ +Copyright (c) 2017-2018, Commonwealth Scientific and Industrial Research Organisation +(CSIRO) ABN 41 687 119 230. + +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 QFPL 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,5 @@ +# Revision history for sv + +## 0.1 -- 2018-03-06 + +* First version. Released on an unsuspecting world. diff --git a/src/Data/Sv.hs b/src/Data/Sv.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv.hs @@ -0,0 +1,75 @@ +{-| +Module : Data.Sv +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +Stability : experimental +Portability : non-portable + +This module exports most of the other modules from the package. It is intended +to be imported unqualified, along with some qualified imports for the +"Data.Sv.Decode" and "Data.Sv.Encode" modules as needed. + +@ +import Data.Sv +import qualified Data.Sv.Decode as D +import qualified Data.Sv.Encode as E +@ +-} + +module Data.Sv ( + -- * Decoding + decode + , parseDecode + , parseDecode' + , parseDecodeFromFile + , parseDecodeFromFile' + , decodeMay + , decodeEither + , decodeEither' + , (>>==) + , (==<<) + , 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 + + -- * Re-exports from contravariant and semigroupoids + , Alt (..) + , Contravariant (..) + , Divisible (..) + , divided + , Decidable (..) + , chosen +) where + +import Data.Functor.Alt (Alt (..)) +import Data.Functor.Contravariant (Contravariant (..)) +import Data.Functor.Contravariant.Divisible (Divisible (..), divided, Decidable (..), chosen) + +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.Parse +import Data.Sv.Print +import Data.Sv.Syntax diff --git a/src/Data/Sv/Decode.hs b/src/Data/Sv/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Decode.hs @@ -0,0 +1,595 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +{-| +Module : Data.Sv.Decode +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +Stability : experimental +Portability : non-portable + +This module contains data structures, combinators, and primitives for +decoding an 'Sv' 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'. +You will need a 'Decode' for your desired type. + +A 'Decode' can be built using the primitives in this file. 'Decode' +is an 'Applicative' and an 'Data.Functor.Alt.Alt', allowing for composition +of these values with '<*>' and '' + +The primitive 'Decode's in this file which use 'ByteString' expect UTF-8 +encoding. The Decode type has an instance of 'Data.Profunctor.Profunctor', +so you can 'lmap' or 'alterInput' to reencode on the way in. + +This module is intended to be imported qualified like so + +@ +import qualified Data.Sv.Decode as D +@ +-} + +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 +) 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)) diff --git a/src/Data/Sv/Decode/Error.hs b/src/Data/Sv/Decode/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Decode/Error.hs @@ -0,0 +1,99 @@ +{-| +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 new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Decode/Type.hs @@ -0,0 +1,146 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Encode.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Data.Sv.Encode +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +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)) diff --git a/src/Data/Sv/Encode/Options.hs b/src/Data/Sv/Encode/Options.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Encode/Options.hs @@ -0,0 +1,98 @@ +{-| +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 new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Encode/Type.hs @@ -0,0 +1,48 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Parse.hs @@ -0,0 +1,114 @@ +{-| +Module : Data.Sv.Parse +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +Stability : experimental +Portability : non-portable +-} + +module Data.Sv.Parse ( + parseSv +, parseSv' +, parseSvFromFile +, parseSvFromFile' +, separatedValues + +, module Data.Sv.Parse.Options +, SvParser (..) +, trifecta +, attoparsecByteString +, attoparsecText +) 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 + +-- | Parse a 'ByteString' as an Sv. +-- +-- This version uses Trifecta, hence it assumes its input is UTF-8 encoded. +parseSv :: ParseOptions ByteString -> ByteString -> Either ByteString (Sv ByteString) +parseSv = parseSv' trifecta + +-- | 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 + +-- | 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 + +-- | 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) + +-- | 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. +-- +-- 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 + } + +-- | 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 + } + +-- | 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 + } diff --git a/src/Data/Sv/Parse/Internal.hs b/src/Data/Sv/Parse/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Parse/Internal.hs @@ -0,0 +1,170 @@ +{-| +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 new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Parse/Options.hs @@ -0,0 +1,97 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Print.hs @@ -0,0 +1,104 @@ +{-| +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 new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Print/Internal.hs @@ -0,0 +1,73 @@ +{-| +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 new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Print/Options.hs @@ -0,0 +1,80 @@ +{-# 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/Syntax.hs b/src/Data/Sv/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Syntax.hs @@ -0,0 +1,18 @@ +{-| +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 new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Syntax/Field.hs @@ -0,0 +1,116 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Syntax/Record.hs @@ -0,0 +1,176 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Syntax/Sv.hs @@ -0,0 +1,219 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Data/Vector/NonEmpty.hs @@ -0,0 +1,79 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Text/Escape.hs @@ -0,0 +1,124 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Text/Newline.hs @@ -0,0 +1,84 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Text/Quote.hs @@ -0,0 +1,72 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Text/Space.hs @@ -0,0 +1,190 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/sv.cabal @@ -0,0 +1,162 @@ +name: sv +version: 0.1 +license: BSD3 +license-file: LICENCE +author: George Wilson +maintainer: george@qfpl.io +copyright: Copyright (c) 2017-2018, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. +category: CSV, Text, Web +synopsis: + Encode and decode separated values (CSV, PSV, ...) + +description: + <> + . + sv (separated values) is a library for parsing, decoding, encoding, and + printing CSV and similar formats (such as PSV, TSV, and many more). + . + 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 + provided primitives and combinators, or you can build one from a parser + from your favourite parser combinator library. + . + 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. + . + Parts of sv are intended to be imported as follows: + . + @ + import Data.Sv + import qualified Data.Sv.Decode as D + import qualified Data.Sv.Encode as E + @ + . + Examples: + . + * Decoding a real CSV: + * 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: + +homepage: https://github.com/qfpl/sv +bug-reports: https://github.com/qfpl/sv/issues +build-type: Simple +extra-source-files: changelog.md +cabal-version: >=1.10 +tested-with: GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.1 + +source-repository head + type: git + location: git@github.com/qfpl/sv.git + +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: + -- other-extensions: + build-depends: ansi-wl-pprint >= 0.6.6 && < 0.7 + , 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 + , semigroupoids >= 5 && <6 + , semigroups >= 0.18 && < 0.19 + , text >= 1.0 && < 1.3 + , 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 + +test-suite tasty + type: + exitcode-stdio-1.0 + main-is: + tasty.hs + other-modules: + Data.Sv.DecodeTest + , Data.Sv.EncodeTest + , Data.Sv.Generators + , Data.Sv.ParseTest + , Data.Sv.PrintTest + , Data.Sv.RoundTrips + default-language: + Haskell2010 + build-depends: + ansi-wl-pprint >= 0.6.6 && < 0.7 + , base >=4.8 && <5 + , bytestring >= 0.9.1.10 && < 0.11 + , contravariant >= 1.2 && < 1.5 + , hedgehog >= 0.5 && < 0.6 + , lens >= 4 && < 5 + , parsers >=0.12 && <0.13 + , semigroupoids >= 5 && <6 + , semigroups >= 0.18 && < 0.19 + , sv + , tasty >= 0.11 && < 1.1 + , tasty-hedgehog >= 0.1 && < 0.2 + , tasty-hunit >= 0.9 && < 0.11 + , text >= 1.0 && < 1.3 + , trifecta >= 1.5 && < 1.8 + , utf8-string >= 1 && < 1.1 + , validation >= 1 && < 1.1 + , vector >= 0.10 && < 0.13 + ghc-options: + -Wall + hs-source-dirs: + test diff --git a/test/Data/Sv/DecodeTest.hs b/test/Data/Sv/DecodeTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Sv/DecodeTest.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Sv.DecodeTest (test_Decode) where + +import Control.Applicative (liftA2) +import Control.Lens ((&), (.~)) +import Data.ByteString +import Data.Functor.Alt +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Semigroup +import qualified Data.Vector as V +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Data.Sv +import qualified Data.Sv.Decode as D + +test_Decode :: TestTree +test_Decode = + testGroup "Decode" [ + intOrStringTest + , varyingLengthTest + ] + +data IntOrString = + I Int | S String + deriving (Eq, Ord, Show) + +intOrString :: Decode ByteString 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 f = sequenceA (V3 f f f) + +v3ios :: 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' :: [V3 IntOrString] +csv1' = + [ I <$> V3 3 4 5 + , V3 (S "quoted text") (S "unquoted text") (I 100) + , V3 (I 7) (S "unquoted text") (I 5) + ] + +opts :: ParseOptions ByteString +opts = defaultParseOptions & headedness .~ Unheaded + +intOrStringTest :: TestTree +intOrStringTest = + testCase "parse successfully" $ + parseDecode v3ios opts csv1 @?= pure csv1' + +varyingLength :: ByteString +varyingLength = intercalate "\r\n" [ + "one" + , "one,two" + , "one,two,three" + , "one,two,three,four" + , "one,two,three,four,five" + ] + +str2 :: 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"]) + ])) diff --git a/test/Data/Sv/EncodeTest.hs b/test/Data/Sv/EncodeTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/Sv/EncodeTest.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Sv.EncodeTest (test_Encode) where + +import Control.Lens (makeClassyPrisms) +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible +import Data.Semigroup ((<>)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Data.Sv +import qualified Data.Sv.Encode as E + +data IntOrString = + I Int | S String + deriving (Eq, Ord, Show) + +makeClassyPrisms ''IntOrString + +data IntAndString = IAS { getInt :: Int, getString :: String } + +intAndString :: Encode IntAndString +intAndString = contramap getInt E.int <> contramap getString E.string + +test_Encode :: TestTree +test_Encode = + testGroup "Encode" [ + divisibleTests + , decidableTests + , encodeTests + , escapeTests + ] + +opts :: EncodeOptions +opts = defaultEncodeOptions + +intOrString :: Encode IntOrString +intOrString = E.encodeOf _I E.int <> E.encodeOf _S E.string + +i :: IntOrString +i = I 5 + +s :: IntOrString +s = S "hello" + +decidableTests :: TestTree +decidableTests = + testGroup "decidable" [ + testCase "encode an Int" $ + encodeRow intOrString opts i @?= "\"5\"" + , testCase "encode a String" $ + encodeRow intOrString opts s @?= "\"hello\"" + ] + +intEmptyAndString :: Encode IntAndString +intEmptyAndString = contramap getInt E.int <> E.empty <> contramap getString E.string + +ias :: IntAndString +ias = IAS 10 "goodbye" + +divisibleTests :: TestTree +divisibleTests = + testGroup "divisible" [ + testCase "encode an IntAndString" $ + encodeRow intAndString opts ias @?= "\"10\",\"goodbye\"" + , testCase "encode an IntAndString with an empty between" $ + 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\"" + +escapeTests :: TestTree +escapeTests = + testGroup "escape" [ + testCase "string" $ + encodeRow E.string opts "hello \"test\" case" @?= "\"hello \"\"test\"\" case\"" + , testCase "text" $ + encodeRow E.text opts "this is also\"a test\"" @?= "\"this is also\"\"a test\"\"\"" + , testCase "bytestring - strict" $ + encodeRow E.byteString opts "\"test\"ing\" " @?= "\"\"\"test\"\"ing\"\" \"" + , testCase "bytestring - lazy" $ + encodeRow E.lazyByteString opts "\"" @?= "\"\"\"\"" + ] diff --git a/test/Data/Sv/Generators.hs b/test/Data/Sv/Generators.hs new file mode 100644 --- /dev/null +++ b/test/Data/Sv/Generators.hs @@ -0,0 +1,115 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Data/Sv/ParseTest.hs @@ -0,0 +1,215 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Data/Sv/PrintTest.hs @@ -0,0 +1,32 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Data/Sv/RoundTrips.hs @@ -0,0 +1,190 @@ +{-# 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/tasty.hs b/test/tasty.hs new file mode 100644 --- /dev/null +++ b/test/tasty.hs @@ -0,0 +1,19 @@ +module Main (main) where + +import Test.Tasty (defaultMain, testGroup) + +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) + +main :: IO () +main = + defaultMain $ testGroup "Tests" [ + test_Parse + , test_Print + , test_Decode + , test_Encode + , test_Roundtrips + ]