packages feed

sv (empty) → 0.1

raw patch · 33 files changed

+4159/−0 lines, 33 filesdep +ansi-wl-pprintdep +attoparsecdep +basesetup-changed

Dependencies added: ansi-wl-pprint, attoparsec, base, bifunctors, bytestring, charset, containers, contravariant, deepseq, hedgehog, lens, mtl, parsec, parsers, profunctors, readable, semigroupoids, semigroups, sv, tasty, tasty-hedgehog, tasty-hunit, text, transformers, trifecta, utf8-string, validation, vector, void

Files

+ LICENCE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,5 @@+# Revision history for sv++## 0.1 -- 2018-03-06++* First version. Released on an unsuspecting world.
+ src/Data/Sv.hs view
@@ -0,0 +1,75 @@+{-|+Module      : Data.Sv+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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
+ src/Data/Sv/Decode.hs view
@@ -0,0 +1,595 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++{-|+Module      : Data.Sv.Decode+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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))
+ src/Data/Sv/Decode/Error.hs view
@@ -0,0 +1,99 @@+{-|+Module      : Data.Sv.Decode.Error+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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+
+ src/Data/Sv/Decode/Type.hs view
@@ -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 <george.wilson@data61.csiro.au>+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)
+ src/Data/Sv/Encode.hs view
@@ -0,0 +1,435 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module      : Data.Sv.Encode+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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+<https://github.com/qfpl/sv/blob/master/examples/src/Data/Sv/Example/Encoding.hs Encoding.hs>+-}++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+, (?>)+, (<?)+, (?>>)+, (<<?)+, encodeOf+, encodeOfMay++-- * Unsafe encodes+, unsafeString+, unsafeText+, unsafeByteString+, unsafeLazyByteString+, unsafeByteStringBuilder+, unsafeConst+) where++import qualified Prelude as P+import Prelude hiding (const, show)++import Control.Applicative ((<$>), (<**>))+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 (<?)+{-# INLINE (?>) #-}++-- | Build an 'Encode' for 'Maybe' given a 'Nothing' and a 'Just' encode.+(<?) :: Encode () -> Encode a -> Encode (Maybe a)+(<?) = choose (maybe (Left ()) Right)+{-# INLINE (<?) #-}++-- | Build an 'Encode' for 'Maybe' given a 'Just' encode and a+-- 'Data.ByteString.Strict.ByteString' for the 'Nothing' case.+(?>>) :: 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.+(<<?) :: Strict.ByteString -> Encode a -> Encode (Maybe a)+(<<?) = flip (?>>)+{-# INLINE (<<?) #-}++-- | Encode a list as a whole row at once, using the same 'Encode'+-- for every element+row :: Encode s -> 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))
+ src/Data/Sv/Encode/Options.hs view
@@ -0,0 +1,98 @@+{-|+Module      : Data.Sv.Encode.Options+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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
+ src/Data/Sv/Encode/Type.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-|+Module      : Data.Sv.Encode.Type+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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)
+ src/Data/Sv/Parse.hs view
@@ -0,0 +1,114 @@+{-|+Module      : Data.Sv.Parse+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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+-- <https://github.com/qfpl/sv/blob/master/examples/csv/species.csv species.csv>+-- 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+  }
+ src/Data/Sv/Parse/Internal.hs view
@@ -0,0 +1,170 @@+{-|+Module      : Data.Sv.Parse.Internal+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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
+ src/Data/Sv/Parse/Options.hs view
@@ -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 <george.wilson@data61.csiro.au>+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
+ src/Data/Sv/Print.hs view
@@ -0,0 +1,104 @@+{-|+Module      : Data.Sv.Print+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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
+ src/Data/Sv/Print/Internal.hs view
@@ -0,0 +1,73 @@+{-|+Module      : Data.Sv.Print.Internal+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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
+ src/Data/Sv/Print/Options.hs view
@@ -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 <george.wilson@data61.csiro.au>+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
+ src/Data/Sv/Syntax.hs view
@@ -0,0 +1,18 @@+{-|+Module      : Data.Sv.Syntax+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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
+ src/Data/Sv/Syntax/Field.hs view
@@ -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 <george.wilson@data61.csiro.au>+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)
+ src/Data/Sv/Syntax/Record.hs view
@@ -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 <george.wilson@data61.csiro.au>+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
+ src/Data/Sv/Syntax/Sv.hs view
@@ -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 <george.wilson@data61.csiro.au>+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+<https://github.com/qfpl/sv/blob/master/examples/src/Data/Sv/Example/Requote.hs Requote.hs>+-}++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'
+ src/Data/Vector/NonEmpty.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveGeneric #-}++{-|+Module      : Data.Vector.NonEmpty+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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)
+ src/Text/Escape.hs view
@@ -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 <george.wilson@data61.csiro.au>+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]
+ src/Text/Newline.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module      : Text.Newline+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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+
+ src/Text/Quote.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++{-|+Module      : Text.Quote+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+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
+ src/Text/Space.hs view
@@ -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 <george.wilson@data61.csiro.au>+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
+ sv.cabal view
@@ -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:+  <<http://i.imgur.com/uZnp9ke.png>>+  .+  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: <https://github.com/qfpl/sv/blob/master/examples/src/Data/Sv/Example/Species.lhs Species.lhs>+  * Encoding data to a CSV: <https://github.com/qfpl/sv/blob/master/examples/src/Data/Sv/Example/Encoding.hs Encoding.hs>+  * Handling NULL and Unknown occuring in a column of numbers: <https://github.com/qfpl/sv/blob/master/examples/src/Data/Sv/Example/Numbers.hs Numbers.hs>+  * Dealing with non-rectangular data: <https://github.com/qfpl/sv/blob/master/examples/src/Data/Sv/Example/Ragged.hs Ragged.hs>+  * Handling multiple logical documents in one file: <https://github.com/qfpl/sv/blob/master/examples/src/Data/Sv/Example/Concat.hs Concat.hs>+  * Integrating with an existing attoparsec parser to read date stamps: <https://github.com/qfpl/sv/blob/master/examples/src/Data/Sv/Example/TableTennis.hs TableTennis.hs>+  * Fixing inconsistent formatting with lenses: <https://github.com/qfpl/sv/blob/master/examples/src/Data/Sv/Example/Requote.hs Requote.hs>++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
+ test/Data/Sv/DecodeTest.hs view
@@ -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"])+      ]))
+ test/Data/Sv/EncodeTest.hs view
@@ -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 "\"" @?= "\"\"\"\""+  ]
+ test/Data/Sv/Generators.hs view
@@ -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
+ test/Data/Sv/ParseTest.hs view
@@ -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
+ test/Data/Sv/PrintTest.hs view
@@ -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)+  ]
+ test/Data/Sv/RoundTrips.hs view
@@ -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)+  ]
+ test/tasty.hs view
@@ -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+  ]