diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,31 @@ +Copyright (c) 2017-2018, Commonwealth Scientific and Industrial Research Organisation +(CSIRO) ABN 41 687 119 230. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of QFPL nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,5 @@ +# Revision history for sv-core + +## 0.1 -- 2018-03-06 + +* Split off from sv-0.1 diff --git a/src/Data/Sv/Alien/Containers.hs b/src/Data/Sv/Alien/Containers.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Alien/Containers.hs @@ -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)) diff --git a/src/Data/Sv/Decode/Core.hs b/src/Data/Sv/Decode/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Decode/Core.hs @@ -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 +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))) diff --git a/src/Data/Sv/Decode/Error.hs b/src/Data/Sv/Decode/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Decode/Error.hs @@ -0,0 +1,89 @@ +{-| +Module : Data.Sv.Decode.Error +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +Stability : experimental +Portability : non-portable +-} + +module Data.Sv.Decode.Error ( + DecodeError (..) +, DecodeErrors (..) + +-- * Convenience constructors +, decodeError +, unexpectedEndOfRow +, expectedEndOfRow +, unknownCategoricalValue +, badParse +, badDecode + +-- * Conversions +, validateEither +, 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 diff --git a/src/Data/Sv/Decode/Type.hs b/src/Data/Sv/Decode/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Decode/Type.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections #-} + +{-| +Module : Data.Sv.Decode.Type +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +Stability : experimental +Portability : non-portable +-} + +module Data.Sv.Decode.Type ( + Decode (..) +, Decode' +, buildDecode +, DecodeState (..) +, runDecodeState +, Ind (..) +, DecodeError (..) +, DecodeErrors (..) +, DecodeValidation +, Validation (..) +) where + +import Control.DeepSeq (NFData) +import Control.Monad.Reader (ReaderT (ReaderT, runReaderT), MonadReader, withReaderT) +import Control.Monad.State (State, runState, state, MonadState) +import Data.Functor.Alt (Alt (())) +import Data.Functor.Apply (Apply) +import Data.Functor.Bind (Bind ((>>-))) +import Data.Functor.Compose (Compose (Compose)) +import Data.List.NonEmpty +import Data.Semigroup (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) diff --git a/src/Data/Sv/Encode/Core.hs b/src/Data/Sv/Encode/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Encode/Core.hs @@ -0,0 +1,419 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Data.Sv.Encode.Core +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +Stability : experimental +Portability : non-portable + +This module is intended to be imported qualified as follows + +@import Data.Sv.Encode.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 + +-} + +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 +, (?>) +, (>) +, (<), 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 () #-} + +-- | Build an 'Encode' for 'Maybe' given a 'Nothing' and a 'Just' encode. +( Encode a -> Encode (Maybe a) +(>) :: Encode a -> Strict.ByteString -> Encode (Maybe a) +(?>>) a s = a ?> const s +{-# INLINE (?>>) #-} + +-- | Build an 'Encode' for 'Maybe' given a 'Data.ByteString.Strict.ByteString' +-- for the 'Nothing' case and a 'Just' encode. +(< Encode a -> Encode (Maybe a) +(<>) +{-# INLINE (< Encode [s] +row enc = Encode $ \opts list -> join $ Seq.fromList $ fmap (getEncode enc opts) list + +-- | Encode a single 'Char' +char :: Encode Char +char = escaped 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 diff --git a/src/Data/Sv/Encode/Options.hs b/src/Data/Sv/Encode/Options.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Encode/Options.hs @@ -0,0 +1,93 @@ +{-| +Module : Data.Sv.Encode.Options +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +Stability : experimental +Portability : non-portable + +Options to configure encoding +-} + +module Data.Sv.Encode.Options ( + EncodeOptions (EncodeOptions, _encodeSeparator, _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 diff --git a/src/Data/Sv/Encode/Type.hs b/src/Data/Sv/Encode/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Encode/Type.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-| +Module : Data.Sv.Encode.Type +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +Stability : experimental +Portability : non-portable + +The core type for encoding +-} + +module Data.Sv.Encode.Type ( + Encode (Encode, getEncode) +) where + +import Data.Bifoldable (bifoldMap) +import 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) diff --git a/src/Data/Sv/Structure/Core.hs b/src/Data/Sv/Structure/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Structure/Core.hs @@ -0,0 +1,21 @@ +{-| +Module : Data.Sv.Structure.Core +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +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 diff --git a/src/Data/Sv/Structure/Headedness.hs b/src/Data/Sv/Structure/Headedness.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Structure/Headedness.hs @@ -0,0 +1,30 @@ +{-| +Module : Data.Sv.Structure.Headedness +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +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 diff --git a/src/Data/Sv/Structure/Newline.hs b/src/Data/Sv/Structure/Newline.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Structure/Newline.hs @@ -0,0 +1,44 @@ +{-| +Module : Data.Sv.Structure.Newline +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +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" + diff --git a/src/Data/Sv/Structure/Separator.hs b/src/Data/Sv/Structure/Separator.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sv/Structure/Separator.hs @@ -0,0 +1,46 @@ +{-| +Module : Data.Sv.Structure.Separator +Copyright : (C) CSIRO 2017-2018 +License : BSD3 +Maintainer : George Wilson +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 #-} diff --git a/sv-core.cabal b/sv-core.cabal new file mode 100644 --- /dev/null +++ b/sv-core.cabal @@ -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: + <> + . + sv-core is the decoding and encoding for the + 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 + () + . + For an example, see + +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 diff --git a/test/Data/Sv/Core/Laws.hs b/test/Data/Sv/Core/Laws.hs new file mode 100644 --- /dev/null +++ b/test/Data/Sv/Core/Laws.hs @@ -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 + ] diff --git a/test/tasty.hs b/test/tasty.hs new file mode 100644 --- /dev/null +++ b/test/tasty.hs @@ -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 + ]