packages feed

sv-core (empty) → 0.1

raw patch · 17 files changed

+1749/−0 lines, 17 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, bifunctors, bytestring, containers, contravariant, deepseq, lens, mtl, parsec, profunctors, readable, semigroupoids, semigroups, sv-core, tasty, tasty-quickcheck, 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-core++## 0.1 -- 2018-03-06++* Split off from sv-0.1
+ src/Data/Sv/Alien/Containers.hs view
@@ -0,0 +1,46 @@+{-+The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow.+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 name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE 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+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.+-}++module Data.Sv.Alien.Containers (intersperseSeq) where++import Control.Applicative ((<**>))+import Data.Sequence (Seq, ViewL (EmptyL, (:<)), viewl, (<|), singleton, empty)++-- Added in containers 0.5.8, but we duplicate it here to support+-- older versions, including 0.5.6.2, which is a GHC boot library for+-- GHC 7.10+intersperseSeq :: a -> Seq a -> Seq a+intersperseSeq y xs = case viewl xs of+  EmptyL -> empty+  p :< ps -> p <| (ps <**> (pure y <| singleton id))
+ src/Data/Sv/Decode/Core.hs view
@@ -0,0 +1,494 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++{-|+Module      : Data.Sv.Decode.Core+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 a CSV into a list of your Haskell datatype.++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.Core as D+@+-}++module Data.Sv.Decode.Core (+  -- * The types+  Decode (..)+, Decode'+, DecodeValidation+, DecodeError (..)+, DecodeErrors (..)++-- * Running Decodes+, decode++-- * Convenience constructors and functions+, decodeMay+, decodeEither+, decodeEither'+, mapErrors+, alterInput++-- * Primitive Decodes+-- ** Field-based+, contents+, char+, byteString+, utf8+, lazyUtf8+, lazyByteString+, string+, int+, integer+, float+, double+, boolean+, boolean'+, ignore+, replace+, exactly+, emptyField+-- ** Row-based+, row++-- * 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+, validateEitherWith+, validateMaybe++-- * Implementation details+, runDecode+, buildDecode+, mkDecode+, promote+, promote'+) where++import Prelude hiding (either)+import qualified Prelude++import Control.Lens (alaf, view)+import Control.Monad (unless)+import Control.Monad.Reader (ReaderT (ReaderT))+import Control.Monad.State (state)+import qualified Data.Attoparsec.ByteString as A+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.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++-- | Decodes a sv into a list of its values using the provided 'Decode'+decode :: Traversable f => Decode' ByteString a -> f (Vector ByteString) -> DecodeValidation ByteString (f a)+decode d = traverse (promote 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 (validateEitherWith e . f)++-- | 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 =+  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 ->+  unless (c == fromString "") (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+    (validateEitherWith (BadDecode . fromString))+    A.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+    (validateEitherWith (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 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 =+  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 -> Vector s -> DecodeValidation s a+promote = promote' id+{-# INLINE promote #-}++-- | Promotes a 'Decode' to work on a whole 'Record' at once.+-- This does not need to be called by the user. Instead use 'decode'.+--+-- This version lets the error string and input string type pararms+-- differ, but needs a function to convert between them.+promote' :: (s -> e) -> Decode e s a -> Vector s -> DecodeValidation e a+promote' se dec vecField =+  let len = length vecField+  in  case runDecode dec vecField (Ind 0) of+    (d, Ind i) ->+      if i >= len+      then d+      else d *> expectedEndOfRow (V.force (fmap se (V.drop i vecField)))
+ src/Data/Sv/Decode/Error.hs view
@@ -0,0 +1,89 @@+{-|+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+, validateEitherWith+, validateMaybe+, validateTrifectaResult++-- * Re-exports from @validation@+, bindValidation+) where++import Data.Validation (Validation (Failure), bindValidation)+import Data.Vector (Vector)+import qualified Text.Trifecta.Result as Trifecta++import Data.Sv.Decode.Type++-- | 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 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 = validateEitherWith id++-- | Build a 'DecodeValidation' from an 'Either', given a function to build the error.+validateEitherWith :: (e -> DecodeError e') -> Either e a -> DecodeValidation e' a+validateEitherWith 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++-- | Convert a "Text.Trifecta" 'Text.Trifecta.Result' to a 'DecodeValidation'+validateTrifectaResult :: (String -> DecodeError e) -> Trifecta.Result a -> DecodeValidation e a+validateTrifectaResult f =+  validateEitherWith f . trifectaResultToEither+    where+      trifectaResultToEither r = case r of+        Trifecta.Failure e -> Left . show . Trifecta._errDoc $ e+        Trifecta.Success a -> Right a
+ src/Data/Sv/Decode/Type.hs view
@@ -0,0 +1,156 @@+{-# 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 (Semigroup)+import Data.Semigroupoid (Semigroupoid (o))+import Data.Profunctor (Profunctor (lmap, rmap))+import Data.Validation (Validation (Success, Failure))+import Data.Vector (Vector)+import GHC.Generics (Generic)++-- | 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, also known+-- as a @SemiAlternative@.+--+-- 'Decode' is not a 'Monad', but we can perform monad-like operations on+-- it with 'Data.Sv.Decode.>>==' or '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++instance Semigroupoid (Decode e) where+  r `o` s = case r of+    Decode (Compose (DecodeState (ReaderT r'))) -> case s of+      Decode (Compose (DecodeState (ReaderT s'))) ->+        buildDecode $ \vec ind -> case runState (s' vec) ind of+            (v,ind') -> case v of+              Failure e -> (Failure e, ind')+              Success x ->+                (fst (runState (r' (pure x)) (Ind 0)), ind')++-- | As we decode a row of data, we walk through its fields. This 'Monad'+-- keeps track of our position.+newtype DecodeState s a =+  DecodeState { getDecodeState :: ReaderT (Vector s) (State Ind) a }+  deriving (Functor, Apply, Applicative, Monad, MonadReader (Vector s), MonadState Ind)++instance Bind (DecodeState s) where+  (>>-) = (>>=)++instance Profunctor DecodeState where+  lmap f (DecodeState s) = DecodeState (withReaderT (fmap f) s)+  rmap = fmap++-- | Convenient constructor for 'Decode' that handles all the newtype noise for you.+buildDecode :: (Vector 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 s -> Ind -> (a, Ind)+runDecodeState = fmap runState . runReaderT . getDecodeState++-- | Newtype for indices into the field vector+newtype Ind = Ind Int deriving (Eq, Ord, Show)++-- | '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 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 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/Core.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module      : Data.Sv.Encode.Core+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.Core 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.Core (+  Encode (..)++-- * Convenience constructors+, mkEncodeBS+, mkEncodeWithOpts++-- * Running an Encode+, encode+, encodeToHandle+, encodeToFile+, encodeBuilder+, encodeRow+, encodeRowBuilder++-- * 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+, unsafeBuilder+, unsafeString+, unsafeText+, unsafeByteString+, unsafeLazyByteString+, unsafeByteStringBuilder+, unsafeConst+) where++import qualified Prelude as P+import Prelude hiding (const, show)++import Control.Lens (Getting, preview, 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)+import Data.Functor.Contravariant (Contravariant (contramap))+import Data.Functor.Contravariant.Divisible (Divisible (conquer), Decidable (choose))+import Data.Monoid (Monoid (mempty), First, (<>), mconcat)+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import GHC.Word (Word8)+import System.IO (BufferMode (BlockBuffering), Handle, hClose, hSetBinaryMode, hSetBuffering, openFile, IOMode (WriteMode))++import Data.Sv.Alien.Containers (intersperseSeq)+import Data.Sv.Encode.Options (EncodeOptions (..), HasEncodeOptions (..), HasSeparator (..), defaultEncodeOptions, Quoting (..))+import Data.Sv.Encode.Type (Encode (Encode, getEncode))+import Data.Sv.Structure.Newline (newlineToBuilder)++-- | 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 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  = newlineToBuilder (_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.word8 (view separator opts))+  in  fold . addSeparators . getEncode e opts++-- | 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 BS.charUtf8++quotingIsNecessary :: EncodeOptions -> LBS.ByteString -> Bool+quotingIsNecessary opts bs =+  LBS.any p bs+    where+      sep = _encodeSeparator opts+      p :: Word8 -> Bool+      p w =+        w == sep ||+        w == 10  || -- lf+        w == 13  || -- cr+        w == 34     -- double quote++quote :: LBS.ByteString -> BS.Builder+quote bs =+  let q = BS.charUtf8 '"'+      bs' = BS.lazyByteString (escapeQuotes bs)+  in  q <> bs' <> q++escapeQuotes :: LBS.ByteString -> LBS.ByteString+escapeQuotes = LBS.concatMap duplicateQuote+  where+    duplicateQuote :: Word8 -> LBS.ByteString+    duplicateQuote 34 = LBS.pack [34,34] -- 34 = quote+    duplicateQuote c  = LBS.singleton c++-- | 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 BS.stringUtf8++-- | Encode a 'Data.Text.Text'+text :: Encode T.Text+text = escaped (BS.byteString . T.encodeUtf8)++-- | Encode a strict 'Data.ByteString.ByteString'+byteString :: Encode Strict.ByteString+byteString = escaped BS.byteString++-- | Encode a lazy 'Data.ByteString.Lazy.ByteString'+lazyByteString :: Encode LBS.ByteString+lazyByteString = escaped BS.lazyByteString++escaped :: (s -> BS.Builder) -> Encode s+escaped build =+  mkEncodeWithOpts $ \opts s ->+    let s' = build s+        lbs = BS.toLazyByteString s'+        quoted = quote lbs+    in  case _quoting opts of+          Never ->+            s'+          AsNeeded ->+            if quotingIsNecessary opts lbs+            then quoted+            else s'+          Always -> quoted++-- | Encode a 'Bool' as True or False+boolTrueFalse :: Encode Bool+boolTrueFalse = mkEncodeBS $ B.bool "False" "True"++-- | Encode a 'Bool' as true of false+booltruefalse :: Encode Bool+booltruefalse = mkEncodeBS $ B.bool "false" "true"++-- | Encode a 'Bool' as yes or no+boolyesno :: Encode Bool+boolyesno = mkEncodeBS $ B.bool "no" "yes"++-- | Encode a 'Bool' as Yes or No+boolYesNo :: Encode Bool+boolYesNo = mkEncodeBS $ B.bool "No" "Yes"++-- | Encode a 'Bool' as Y or N+boolYN :: Encode Bool+boolYN = mkEncodeBS $ B.bool "N" "Y"++-- | Encode a 'Bool' as 1 or 0+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
+ src/Data/Sv/Encode/Options.hs view
@@ -0,0 +1,93 @@+{-|+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, _quoting, _newline, _terminalNewline)+, HasEncodeOptions (encodeOptions, quoting, newline, terminalNewline)+, HasSeparator (separator)+, Quoting (..)+, defaultEncodeOptions+) where++import Control.Lens (Lens')++import Data.Sv.Structure.Newline (Newline, lf)+import Data.Sv.Structure.Separator (Separator, HasSeparator (separator), comma)++-- | Should the output file have quotes around every value, or only when they+-- are required?+--+-- Beware the 'Never' constructor. It can construct malformed CSV files if+-- there are fields containing quotes, newlines, or separators. It is the+-- fastest option though, so you might like to use it if you're sure none+-- of your encoded data will include those characters.+data Quoting+  = Always+  | AsNeeded+  | Never++-- | 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+    -- | Would you like quotes around your values? If so, double quotes or single? Deafult: Double quotes+  , _quoting :: Quoting+    -- | What kind of newline would you like? Default: LF+  , _newline :: Newline+    -- | Should the file be terminated with a newline? Default: No+  , _terminalNewline :: Bool+  }++-- | Classy lenses for 'EncodeOptions'+--+-- @+-- import Control.Lens+--+-- defaultEncodeOptions & newline .~ crlf & quoting .~ Always+-- @+class HasSeparator c => HasEncodeOptions c where+  encodeOptions :: Lens' c EncodeOptions+  quoting :: Lens' c Quoting+  {-# INLINE quoting #-}+  newline :: Lens' c Newline+  {-# INLINE newline #-}+  terminalNewline :: Lens' c Bool+  {-# INLINE terminalNewline #-}+  newline = encodeOptions . newline+  quoting = encodeOptions . quoting+  terminalNewline = encodeOptions . terminalNewline++instance HasSeparator EncodeOptions where+  separator f (EncodeOptions x1 x2 x3 x4) =+    fmap (\ y -> EncodeOptions y x2 x3 x4) (f x1)+  {-# INLINE separator #-}++instance HasEncodeOptions EncodeOptions where+  encodeOptions = id+  {-# INLINE encodeOptions #-}+  quoting f (EncodeOptions x1 x2 x3 x4) =+    fmap (\ y -> EncodeOptions x1 y x3 x4) (f x2)+  {-# INLINE quoting #-}+  newline f (EncodeOptions x1 x2 x3 x4) =+    fmap (\ y -> EncodeOptions x1 x2 y x4) (f x3)+  {-# INLINE newline #-}+  terminalNewline f (EncodeOptions x1 x2 x3 x4) =+    fmap (EncodeOptions x1 x2 x3) (f x4)+  {-# INLINE terminalNewline #-}++-- | The default options for encoding.+--+-- The default is a CSV file with quotes when necessary, LF lines,+-- and no terminating newline.+defaultEncodeOptions :: EncodeOptions+defaultEncodeOptions = EncodeOptions comma AsNeeded lf 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 Data.ByteString.Builder (Builder)+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 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/Structure/Core.hs view
@@ -0,0 +1,21 @@+{-|+Module      : Data.Sv.Structure.Core+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+Stability   : experimental+Portability : non-portable+-}++module Data.Sv.Structure.Core (+  Separator+, comma+, pipe+, tab+, HasSeparator (separator)+, Headedness (..)+, HasHeadedness (..)+) where++import Data.Sv.Structure.Headedness+import Data.Sv.Structure.Separator
+ src/Data/Sv/Structure/Headedness.hs view
@@ -0,0 +1,30 @@+{-|+Module      : Data.Sv.Structure.Headedness+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+Stability   : experimental+Portability : non-portable+-}++module Data.Sv.Structure.Headedness (+  Headedness (..)+, HasHeadedness (..)+) where++import Control.Lens (Lens')++-- | Does the CSV 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
+ src/Data/Sv/Structure/Newline.hs view
@@ -0,0 +1,44 @@+{-|+Module      : Data.Sv.Structure.Newline+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+Stability   : experimental+Portability : non-portable+-}++{-# LANGUAGE OverloadedStrings #-}++module Data.Sv.Structure.Newline (+  Newline (UnsafeMkNewline, toByteString)+, newlineToBuilder+, crlf+, lf+) where++import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, byteString)+import qualified Data.ByteString.UTF8 as UTF8++-- | 'Newline' is a newtype around 'ByteString'+newtype Newline+  = UnsafeMkNewline { toByteString :: ByteString }+    deriving (Eq, Ord)++instance Show Newline where+  showsPrec _ = showString . UTF8.toString . toByteString++-- | Convert a 'Newline' to a ByteString 'Builder'. This is used by+-- encoding.+newlineToBuilder :: Newline -> Builder+newlineToBuilder = byteString . toByteString++-- | Unix/Linux newlines: a line feed character+lf :: Newline+lf = UnsafeMkNewline "\n"++-- | DOS newlines: a carriage return character followed by a+-- line feed character+crlf :: Newline+crlf = UnsafeMkNewline "\r\n"+
+ src/Data/Sv/Structure/Separator.hs view
@@ -0,0 +1,46 @@+{-|+Module      : Data.Sv.Structure.Separator+Copyright   : (C) CSIRO 2017-2018+License     : BSD3+Maintainer  : George Wilson <george.wilson@data61.csiro.au>+Stability   : experimental+Portability : non-portable+-}++module Data.Sv.Structure.Separator (+  Separator+, comma+, pipe+, tab+, HasSeparator (separator)+) where++import Control.Lens (Lens')+import GHC.Word (Word8)++-- | By what are your values separated? The answer is often 'comma', but not always.+--+-- A 'Separator' is just a 'Word8'. 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.+type Separator = Word8++-- | The venerable comma separator. Used for CSV documents.+comma :: Separator+comma = 44++-- | The pipe separator. Used for PSV documents.+pipe :: Separator+pipe = 124++-- | Tab is a separator too - why not?+tab :: Separator+tab = 9++-- | Classy lens for 'Separator'+class HasSeparator c where+  separator :: Lens' c Separator++instance HasSeparator Word8 where+  separator = id+  {-# INLINE separator #-}
+ sv-core.cabal view
@@ -0,0 +1,102 @@+name:                sv-core+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-core is the decoding and encoding for the+  <https://hackage.haskell.org/package/sv sv> CSV library. This is split+  off into its own package so that one swap out sv's parser without incurring+  a dependency on the default parser+  (<https://hackage.haskell.org/package/hw-dsv hw-dsv>)+  .+  For an example, see <https://hackage.haskell.org/package/sv-cassava sv-cassava>++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.3+                     , GHC == 8.6.1++source-repository    head+  type:              git+  location:          git@github.com/qfpl/sv.git++library+  exposed-modules:     Data.Sv.Structure.Core+                       , Data.Sv.Structure.Headedness+                       , Data.Sv.Structure.Newline+                       , Data.Sv.Structure.Separator+                       , Data.Sv.Decode.Core+                       , Data.Sv.Decode.Error+                       , Data.Sv.Decode.Type+                       , Data.Sv.Encode.Core+                       , Data.Sv.Encode.Options+                       , Data.Sv.Encode.Type+  other-modules:       Data.Sv.Alien.Containers+  -- other-extensions:    +  build-depends:       attoparsec >= 0.12.1.4 && < 0.14+                       , base >=4.8 && <5+                       , bifunctors >= 5.1 && < 6+                       , bytestring >= 0.9.1.10 && < 0.11+                       , containers >= 0.4 && < 0.7+                       , contravariant >= 1.2 && < 1.6+                       , deepseq >= 1.1 && < 1.5+                       , lens >= 4 && < 5+                       , mtl >= 2.0.1 && < 2.3+                       , parsec >= 3.1 && < 3.2+                       , 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 && < 2.1+                       , 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 -O2++test-suite             tasty+  type:+                       exitcode-stdio-1.0+  main-is:+                       tasty.hs+  other-modules:+                       Data.Sv.Core.Laws+  default-language:+                       Haskell2010+  build-depends:+                       base >=4.8 && <5+                       , bytestring >= 0.9.1.10 && < 0.11+                       , semigroupoids >= 5 && <6+                       , sv-core+                       , profunctors >= 5 && < 5.4+                       , semigroups >= 0.18 && < 0.19+                       , tasty >= 0.11 && < 1.2+                       , tasty-quickcheck >= 0.9 && < 0.11+                       , text >= 1.0 && < 1.3+                       , validation >= 1 && < 1.1+                       , vector >= 0.10 && < 0.13+                       , QuickCheck >= 2.10 && < 2.12+  ghc-options:+                       -Wall+  hs-source-dirs:+                       test
+ test/Data/Sv/Core/Laws.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}++module Data.Sv.Core.Laws (test_Laws) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Profunctor (Profunctor (dimap))+import Data.Semigroupoid (Semigroupoid (o))+import qualified Data.Validation as V+import Data.Vector (Vector, fromList, toList)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (Arbitrary (arbitrary), CoArbitrary (coarbitrary), Gen, testProperty, oneof, listOf)++import Data.Sv.Decode.Type+import qualified Data.Sv.Decode.Core as D++test_Laws :: TestTree+test_Laws =+  testGroup "Laws"+    [ testGroup "Decode Semigroupoid" $ fmap (uncurry testProperty)+        [ ("Decode Semigroupoid associativity", decodeAssoc)+        ]+    ]++decodeAssoc :: Gen Bool+decodeAssoc = do+  dec1 <- decodeGen :: Gen (Decode ByteString ByteString ByteString)+  dec2 <- decodeGen :: Gen (Decode ByteString ByteString ByteString)+  dec3 <- decodeGen :: Gen (Decode ByteString ByteString ByteString)+  v <- arbOut+  i <- arbOut+  let comp1 = (dec1 `o` dec2) `o` dec3+  let comp2 = dec1 `o` (dec2 `o` dec3)+  pure (eqDecode v i comp1 comp2)+++eqDecode :: (Eq e, Eq a) => Vector s -> Ind -> Decode e s a -> Decode e s a -> Bool+eqDecode v i d e =+  D.runDecode d v i == D.runDecode e v i++decodeGen :: (CoArbitrary (In s), Arbitrary (Out a), Arbitrary (Out e)) => Gen (Decode e s a)+decodeGen =+  buildDecode <$> (unwrap <$> arbitrary)++unwrap :: (Input s -> Output e a) -> Vector s -> Ind -> (Validation e a, Ind)+unwrap = curry . dimap Input unwrapO++newtype Output e a =+  Output { unwrapO :: (Validation e a, Ind) }++newtype Input s = Input (Vector s, Ind)++newtype In a = In a+newtype Out a = Out { unout :: a }++coarbIn :: CoArbitrary (In a) => a -> Gen b -> Gen b+coarbIn = coarbitrary . In++arbOut :: Arbitrary (Out a) => Gen a+arbOut = unout <$> arbitrary++instance (Arbitrary (Out e), Arbitrary (Out a)) => Arbitrary (Output e a) where+  arbitrary =+    Output <$>+      ((,) <$> oneof [V.Failure <$> arbOut, V.Success <$> arbOut]+          <*> (Ind <$> arbOut))++instance (CoArbitrary (In (Vector s)), CoArbitrary (In Ind)) => CoArbitrary (Input s) where+  coarbitrary (Input (v,i)) = coarbIn v . coarbIn i++instance Arbitrary (Out ByteString) where+  arbitrary = Out <$> (BS.pack <$> arbitrary)++instance CoArbitrary (In ByteString) where+  coarbitrary (In bs) = coarbitrary (BS.unpack bs)++instance Arbitrary (Out Ind) where+  arbitrary = Out . Ind <$> arbitrary++instance Arbitrary (Out Int) where+  arbitrary = Out <$> arbitrary++instance CoArbitrary (In s) => CoArbitrary (In (Vector s)) where+  coarbitrary (In v) = coarbitrary (In <$> toList v)++instance CoArbitrary (In Ind) where+  coarbitrary (In (Ind i)) = coarbitrary i++instance Arbitrary (Out e) => Arbitrary (Out (DecodeErrors e)) where+  arbitrary = Out . DecodeErrors <$> arbOut++instance Arbitrary (Out e) => Arbitrary (Out (NonEmpty e)) where+  arbitrary = Out <$> ((:|) <$> arbOut <*> arbOut)++instance Arbitrary (Out e) => Arbitrary (Out [e]) where+  arbitrary = Out <$> listOf arbOut++instance Arbitrary (Out e) => Arbitrary (Out (Vector e)) where+  arbitrary = Out . fromList <$> arbOut++instance Arbitrary (Out e) => Arbitrary (Out (DecodeError e)) where+  arbitrary = Out <$> oneof+    [ pure UnexpectedEndOfRow+    , ExpectedEndOfRow <$> arbOut+    , UnknownCategoricalValue <$> arbOut <*> arbOut+    , BadParse <$> arbOut+    , BadDecode <$> arbOut+    ]
+ test/tasty.hs view
@@ -0,0 +1,11 @@+module Main (main) where++import Test.Tasty (defaultMain, testGroup)++import Data.Sv.Core.Laws (test_Laws)++main :: IO ()+main =+  defaultMain $ testGroup "Tests" [+    test_Laws+  ]