packages feed

siphon (empty) → 0.1

raw patch · 13 files changed

+1016/−0 lines, 13 filesdep +HUnitdep +QuickCheckdep +attoparsecsetup-changed

Dependencies added: HUnit, QuickCheck, attoparsec, base, bytestring, colonnade, contravariant, either, pipes, siphon, test-framework, test-framework-hunit, test-framework-quickcheck2, text, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Andrew Martin (c) 2016++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 Andrew Martin 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
+ siphon.cabal view
@@ -0,0 +1,61 @@+name:                siphon+version:             0.1+synopsis:            Generic types and functions for columnar encoding and decoding+description:         Please see README.md+homepage:            https://github.com/andrewthad/colonnade#readme+license:             BSD3+license-file:        LICENSE+author:              Andrew Martin+maintainer:          andrew.thaddeus@gmail.com+copyright:           2016 Andrew Martin+category:            web+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:+    Siphon.Text+    Siphon.ByteString.Char8+    Siphon+    Siphon.Types+    Siphon.Content+    Siphon.Encoding+    Siphon.Decoding+    Siphon.Internal+    Siphon.Internal.Text+  build-depends:+      base >= 4.7 && < 5+    , colonnade+    , text+    , bytestring+    , contravariant+    , vector+    , pipes+    , attoparsec+  default-language:    Haskell2010++test-suite siphon-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Test.hs+  build-depends:+      base+    , either+    , siphon+    , colonnade+    , contravariant+    , test-framework+    , test-framework-quickcheck2+    , QuickCheck+    , text+    , bytestring+    , pipes+    , HUnit+    , test-framework-hunit+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/andrewthad/colonnade
+ src/Siphon.hs view
@@ -0,0 +1,11 @@+module Siphon where++-- encode :: Pipe a (Vector c) m x+-- encode+-- decode :: Pipe (Vector c) a m x++-- encode ::++-- row :: Vector (Escaped Text) -> Text+-- row = Vector.+
+ src/Siphon/ByteString/Char8.hs view
@@ -0,0 +1,1 @@+module Siphon.ByteString.Char8 where
+ src/Siphon/Content.hs view
@@ -0,0 +1,8 @@+module Siphon.Content+  ( byteStringChar8+  , text+  ) where++import Siphon.Internal (byteStringChar8)+import Siphon.Internal.Text (text)+
+ src/Siphon/Decoding.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE RankNTypes   #-}+{-# LANGUAGE BangPatterns #-}++module Siphon.Decoding where++import Siphon.Types+import Colonnade.Types+import Siphon.Internal (row,comma)+import Data.Text (Text)+import Data.ByteString (ByteString)+import Pipes (yield,Pipe,Consumer',Producer,await)+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import qualified Colonnade.Decoding as Decoding+import qualified Data.Attoparsec.ByteString as AttoByteString+import qualified Data.ByteString.Char8 as ByteString+import qualified Data.Attoparsec.Types as Atto++mkParseError :: Int -> [String] -> String -> DecodingRowError f content+mkParseError i ctxs msg = id+  $ DecodingRowError i+  $ RowErrorParse $ concat+    [ "Contexts: ["+    , concat ctxs+    , "], Error Message: ["+    , msg+    , "]"+    ]++-- | This is a convenience function for working with @pipes-text@.+--   It will convert a UTF-8 decoding error into a `DecodingRowError`,+--   so the pipes can be properly chained together.+convertDecodeError :: String -> Either (Producer ByteString m ()) () -> Maybe (DecodingRowError f c)+convertDecodeError encodingName (Left _) = Just (DecodingRowError 0 (RowErrorMalformed encodingName))+convertDecodeError _ (Right ()) = Nothing++-- | This is seldom useful but is included for completeness.+headlessPipe :: Monad m+  => Siphon c+  -> Decoding Headless c a+  -> Pipe c a m (DecodingRowError Headless c)+headlessPipe sd decoding = uncheckedPipe requiredLength 0 sd indexedDecoding Nothing+  where+  indexedDecoding = Decoding.headlessToIndexed decoding+  requiredLength = Decoding.length indexedDecoding++indexedPipe :: Monad m+  => Siphon c+  -> Decoding (Indexed Headless) c a+  -> Pipe c a m (DecodingRowError Headless c)+indexedPipe sd decoding = do+  e <- consumeGeneral 0 sd mkParseError+  case e of+    Left err -> return err+    Right (firstRow, mleftovers) ->+      let req = Decoding.maxIndex decoding+          vlen = Vector.length firstRow+       in if vlen < req+            then return (DecodingRowError 0 (RowErrorMinSize req vlen))+            else case Decoding.uncheckedRun decoding firstRow of+              Left cellErr -> return $ DecodingRowError 0 $ RowErrorDecode cellErr+              Right a -> do+                yield a+                uncheckedPipe vlen 1 sd decoding mleftovers+++headedPipe :: (Monad m, Eq c)+  => Siphon c+  -> Decoding Headed c a+  -> Pipe c a m (DecodingRowError Headed c)+headedPipe sd decoding = do+  e <- consumeGeneral 0 sd mkParseError+  case e of+    Left err -> return err+    Right (headers, mleftovers) ->+      case Decoding.headedToIndexed headers decoding of+        Left headingErrs -> return (DecodingRowError 0 (RowErrorHeading headingErrs))+        Right indexedDecoding ->+          let requiredLength = Vector.length headers+           in uncheckedPipe requiredLength 1 sd indexedDecoding mleftovers+++uncheckedPipe :: Monad m+  => Int -- ^ expected length of each row+  -> Int -- ^ index of first row, usually zero or one+  -> Siphon c+  -> Decoding (Indexed f) c a+  -> Maybe c+  -> Pipe c a m (DecodingRowError f c)+uncheckedPipe requiredLength ix sd d mleftovers =+  pipeGeneral ix sd mkParseError checkedRunWithRow mleftovers+  where+  checkedRunWithRow rowIx v =+    let vlen = Vector.length v in+    if vlen /= requiredLength+      then Left $ DecodingRowError rowIx+                $ RowErrorSize requiredLength vlen+      else Decoding.uncheckedRunWithRow rowIx d v++consumeGeneral :: Monad m+  => Int+  -> Siphon c+  -> (Int -> [String] -> String -> e)+  -> Consumer' c m (Either e (Vector c, Maybe c))+consumeGeneral ix (Siphon _ _ parse isNull) wrapParseError = do+  c <- awaitSkip isNull+  handleResult (parse c)+  where+  go k = do+    c <- awaitSkip isNull+    handleResult (k c)+  handleResult r = case r of+    Atto.Fail _ ctxs msg -> return $ Left+      $ wrapParseError ix ctxs msg+    Atto.Done c v ->+      let mcontent = if isNull c+            then Nothing+            else Just c+       in return (Right (v,mcontent))+    Atto.Partial k -> go k++pipeGeneral :: Monad m+  => Int -- ^ index of first row, usually zero or one+  -> Siphon c+  -> (Int -> [String] -> String -> e)+  -> (Int -> Vector c -> Either e a)+  -> Maybe c -- ^ leftovers that should be handled first+  -> Pipe c a m e+pipeGeneral initIx (Siphon _ _ parse isNull) wrapParseError decodeRow mleftovers =+  case mleftovers of+    Nothing -> go1 initIx+    Just leftovers -> handleResult initIx (parse leftovers)+  where+  go1 !ix = do+    c1 <- awaitSkip isNull+    handleResult ix (parse c1)+  go2 !ix c1 = handleResult ix (parse c1)+  go3 !ix k = do+    c1 <- awaitSkip isNull+    handleResult ix (k c1)+  handleResult !ix r = case r of+    Atto.Fail _ ctxs msg -> return $ wrapParseError ix ctxs msg+    Atto.Done c1 v -> do+      case decodeRow ix v of+        Left err -> return err+        Right r -> do+          yield r+          let ixNext = ix + 1+          if isNull c1 then go1 ixNext else go2 ixNext c1+    Atto.Partial k -> go3 ix k++awaitSkip :: Monad m+          => (a -> Bool)+          -> Consumer' a m a+awaitSkip f = go where+  go = do+    a <- await+    if f a then go else return a++
+ src/Siphon/Encoding.hs view
@@ -0,0 +1,35 @@+module Siphon.Encoding where++import Siphon.Types+import Colonnade.Types+import Pipes (Pipe,yield)+import qualified Pipes.Prelude as Pipes+import qualified Colonnade.Encoding as Encoding++row :: Siphon c+    -> Encoding f c a+    -> a+    -> c+row (Siphon escape intercalate _ _) e =+  intercalate . Encoding.runRow escape e++header :: Siphon c+       -> Encoding Headed c a+       -> c+header (Siphon escape intercalate _ _) e =+  intercalate (Encoding.runHeader escape e)++pipe :: Monad m+  => Siphon c+  -> Encoding f c a+  -> Pipe a c m x+pipe siphon encoding = Pipes.map (row siphon encoding)++headedPipe :: Monad m+  => Siphon c+  -> Encoding Headed c a+  -> Pipe a c m x+headedPipe siphon encoding = do+  yield (header siphon encoding)+  pipe siphon encoding+
+ src/Siphon/Internal.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE BangPatterns #-}++-- | A CSV parser. The parser defined here is RFC 4180 compliant, with+-- the following extensions:+--+--  * Empty lines are ignored.+--+--  * Non-escaped fields may contain any characters except+--    double-quotes, commas, carriage returns, and newlines.+--+--  * Escaped fields may contain any characters (but double-quotes+--    need to be escaped).+--+-- The functions in this module can be used to implement e.g. a+-- resumable parser that is fed input incrementally.+module Siphon.Internal where++import Siphon.Types++import Data.ByteString.Builder (toLazyByteString,byteString)+import qualified Data.ByteString.Char8 as BC8+import Control.Applicative (optional)+import Data.Attoparsec.ByteString.Char8 (char, endOfInput, string)+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.Lazy as AL+import qualified Data.Attoparsec.Zepto as Z+import qualified Data.ByteString as S+import qualified Data.ByteString.Unsafe as S+import qualified Data.Vector as V+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LByteString+import qualified Data.ByteString.Builder as Builder+import qualified Data.Text as T+import Data.Word (Word8)+import Data.Vector (Vector)+import Data.ByteString (ByteString)+import Data.Coerce (coerce)+import Siphon.Types++import Control.Applicative+import Data.Monoid++byteStringChar8 :: Siphon ByteString+byteStringChar8 = Siphon+  escape+  encodeRow+  (A.parse (row comma))+  B.null++encodeRow :: Vector (Escaped ByteString) -> ByteString+encodeRow = id+  . flip B.append (B.singleton newline)+  . B.intercalate (B.singleton comma)+  . V.toList+  . coerce++escape :: ByteString -> Escaped ByteString+escape t = case B.find (\c -> c == newline || c == cr || c == comma || c == doubleQuote) t of+  Nothing -> Escaped t+  Just _  -> escapeAlways t++-- | This implementation is definitely suboptimal.+-- A better option (which would waste a little space+-- but would be much faster) would be to build the+-- new bytestring by writing to a buffer directly.+escapeAlways :: ByteString -> Escaped ByteString+escapeAlways t = Escaped $ LByteString.toStrict $ Builder.toLazyByteString $+     Builder.word8 doubleQuote+  <> B.foldl+      (\ acc b -> acc <> if b == doubleQuote+          then Builder.byteString+            (B.pack [doubleQuote,doubleQuote])+          else Builder.word8 b)+      mempty+      t+  <> Builder.word8 doubleQuote++-- | Specialized version of 'sepBy1'' which is faster due to not+-- accepting an arbitrary separator.+sepByDelim1' :: AL.Parser a+             -> Word8  -- ^ Field delimiter+             -> AL.Parser [a]+sepByDelim1' p !delim = liftM2' (:) p loop+  where+    loop = do+        mb <- A.peekWord8+        case mb of+            Just b | b == delim -> liftM2' (:) (A.anyWord8 *> p) loop+            _                   -> pure []+{-# INLINE sepByDelim1' #-}++-- | Specialized version of 'sepBy1'' which is faster due to not+-- accepting an arbitrary separator.+sepByEndOfLine1' :: AL.Parser a+                 -> AL.Parser [a]+sepByEndOfLine1' p = liftM2' (:) p loop+  where+    loop = do+        mb <- A.peekWord8+        case mb of+            Just b | b == cr ->+                liftM2' (:) (A.anyWord8 *> A.word8 newline *> p) loop+                   | b == newline ->+                liftM2' (:) (A.anyWord8 *> p) loop+            _ -> pure []+{-# INLINE sepByEndOfLine1' #-}++-- | Parse a record, not including the terminating line separator. The+-- terminating line separate is not included as the last record in a+-- CSV file is allowed to not have a terminating line separator. You+-- most likely want to use the 'endOfLine' parser in combination with+-- this parser.+row :: Word8  -- ^ Field delimiter+    -> AL.Parser (Vector ByteString)+row !delim = rowNoNewline delim <* endOfLine+{-# INLINE row #-}++rowNoNewline :: Word8  -- ^ Field delimiter+             -> AL.Parser (Vector ByteString)+rowNoNewline !delim = V.fromList <$!> field delim `sepByDelim1'` delim+{-# INLINE rowNoNewline #-}++removeBlankLines :: [Vector ByteString] -> [Vector ByteString]+removeBlankLines = filter (not . blankLine)++-- | Parse a field. The field may be in either the escaped or+-- non-escaped format. The return value is unescaped.+field :: Word8 -> AL.Parser ByteString+field !delim = do+    mb <- A.peekWord8+    -- We purposely don't use <|> as we want to commit to the first+    -- choice if we see a double quote.+    case mb of+        Just b | b == doubleQuote -> escapedField+        _                         -> unescapedField delim+{-# INLINE field #-}++escapedField :: AL.Parser S.ByteString+escapedField = do+    _ <- dquote+    -- The scan state is 'True' if the previous character was a double+    -- quote.  We need to drop a trailing double quote left by scan.+    s <- S.init <$> (A.scan False $ \s c -> if c == doubleQuote+                                            then Just (not s)+                                            else if s then Nothing+                                                 else Just False)+    if doubleQuote `S.elem` s+        then case Z.parse unescape s of+            Right r  -> return r+            Left err -> fail err+        else return s++unescapedField :: Word8 -> AL.Parser S.ByteString+unescapedField !delim = A.takeWhile (\ c -> c /= doubleQuote &&+                                            c /= newline &&+                                            c /= delim &&+                                            c /= cr)++dquote :: AL.Parser Char+dquote = char '"'++-- | This could be improved. We could avoid the builder and just+-- write to a buffer directly.+unescape :: Z.Parser S.ByteString+unescape = (LByteString.toStrict . toLazyByteString) <$!> go mempty where+  go acc = do+    h <- Z.takeWhile (/= doubleQuote)+    let rest = do+          start <- Z.take 2+          if (S.unsafeHead start == doubleQuote &&+              S.unsafeIndex start 1 == doubleQuote)+              then go (acc `mappend` byteString h `mappend` byteString (BC8.singleton '"'))+              else fail "invalid CSV escape sequence"+    done <- Z.atEnd+    if done+      then return (acc `mappend` byteString h)+      else rest++-- | A strict version of 'Data.Functor.<$>' for monads.+(<$!>) :: Monad m => (a -> b) -> m a -> m b+f <$!> m = do+    a <- m+    return $! f a+{-# INLINE (<$!>) #-}++infixl 4 <$!>++-- | Is this an empty record (i.e. a blank line)?+blankLine :: V.Vector B.ByteString -> Bool+blankLine v = V.length v == 1 && (B.null (V.head v))++-- | A version of 'liftM2' that is strict in the result of its first+-- action.+liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c+liftM2' f a b = do+    !x <- a+    y <- b+    return (f x y)+{-# INLINE liftM2' #-}+++-- | Match either a single newline character @\'\\n\'@, or a carriage+-- return followed by a newline character @\"\\r\\n\"@, or a single+-- carriage return @\'\\r\'@.+endOfLine :: A.Parser ()+endOfLine = (A.word8 newline *> return ()) <|> (string (BC8.pack "\r\n") *> return ()) <|> (A.word8 cr *> return ())+{-# INLINE endOfLine #-}++doubleQuote, newline, cr, comma :: Word8+doubleQuote = 34+newline = 10+cr = 13+comma = 44+
+ src/Siphon/Internal/Text.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE BangPatterns #-}++module Siphon.Internal.Text where++import Siphon.Types++import Control.Applicative (optional)+import Data.Attoparsec.Text (char, endOfInput, string)+import qualified Data.Attoparsec.Text as A+import qualified Data.Attoparsec.Text.Lazy as AL+import qualified Data.Attoparsec.Zepto as Z+import qualified Data.Text as T+import qualified Data.Text as Text+import qualified Data.Vector as V+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Builder as Builder+import Data.Text.Lazy.Builder (Builder)+import Data.Word (Word8)+import Data.Vector (Vector)+import Data.Text (Text)+import Data.Coerce (coerce)+import Siphon.Types++import Control.Applicative+import Data.Monoid++text :: Siphon Text+text = Siphon+  escape+  encodeRow+  (A.parse (row comma))+  Text.null++encodeRow :: Vector (Escaped Text) -> Text+encodeRow = id+  . flip Text.append (Text.singleton newline)+  . Text.intercalate (Text.singleton comma)+  . V.toList+  . coerce++escape :: Text -> Escaped Text+escape t = case Text.find (\c -> c == newline || c == cr || c == comma || c == doubleQuote) t of+  Nothing -> Escaped t+  Just _  -> escapeAlways t++-- | This implementation is definitely suboptimal.+-- A better option (which would waste a little space+-- but would be much faster) would be to build the+-- new text by writing to a buffer directly.+escapeAlways :: Text -> Escaped Text+escapeAlways t = Escaped $ Text.concat+  [ textDoubleQuote+  , Text.replace textDoubleQuote (Text.pack [doubleQuote,doubleQuote]) t+  , textDoubleQuote+  ]++-- | Specialized version of 'sepBy1'' which is faster due to not+-- accepting an arbitrary separator.+sepByDelim1' :: A.Parser a+             -> Char  -- ^ Field delimiter+             -> A.Parser [a]+sepByDelim1' p !delim = liftM2' (:) p loop+  where+    loop = do+        mb <- A.peekChar+        case mb of+            Just b | b == delim -> liftM2' (:) (A.anyChar *> p) loop+            _                   -> pure []+{-# INLINE sepByDelim1' #-}++-- | Specialized version of 'sepBy1'' which is faster due to not+-- accepting an arbitrary separator.+sepByEndOfLine1' :: A.Parser a+                 -> A.Parser [a]+sepByEndOfLine1' p = liftM2' (:) p loop+  where+    loop = do+        mb <- A.peekChar+        case mb of+            Just b | b == cr ->+                liftM2' (:) (A.anyChar *> A.char newline *> p) loop+                   | b == newline ->+                liftM2' (:) (A.anyChar *> p) loop+            _ -> pure []+{-# INLINE sepByEndOfLine1' #-}++-- | Parse a record, not including the terminating line separator. The+-- terminating line separate is not included as the last record in a+-- CSV file is allowed to not have a terminating line separator. You+-- most likely want to use the 'endOfLine' parser in combination with+-- this parser.+row :: Char  -- ^ Field delimiter+    -> A.Parser (Vector Text)+row !delim = rowNoNewline delim <* endOfLine+{-# INLINE row #-}++rowNoNewline :: Char  -- ^ Field delimiter+             -> A.Parser (Vector Text)+rowNoNewline !delim = V.fromList <$!> field delim `sepByDelim1'` delim+{-# INLINE rowNoNewline #-}++-- | Parse a field. The field may be in either the escaped or+-- non-escaped format. The return value is unescaped.+field :: Char -> A.Parser Text+field !delim = do+    mb <- A.peekChar+    -- We purposely don't use <|> as we want to commit to the first+    -- choice if we see a double quote.+    case mb of+        Just b | b == doubleQuote -> escapedField+        _                         -> unescapedField delim+{-# INLINE field #-}++escapedField :: A.Parser Text+escapedField = do+  _ <- dquote -- This can probably be replaced with anyChar+  b <- escapedFieldInner mempty+  return (LText.toStrict (Builder.toLazyText b))++escapedFieldInner :: Builder -> A.Parser Builder+escapedFieldInner b = do+  t <- A.takeTill (== doubleQuote)+  _ <- A.anyChar -- this will always be a double quote+  c <- A.peekChar'+  if c == doubleQuote+    then do+      _ <- A.anyChar -- this will always be a double quote+      escapedFieldInner (b `mappend` Builder.fromText t `mappend` Builder.fromText textDoubleQuote)+    else return (b `mappend` Builder.fromText t)++unescapedField :: Char -> A.Parser Text+unescapedField !delim = A.takeWhile (\ c -> c /= doubleQuote &&+                                            c /= newline &&+                                            c /= delim &&+                                            c /= cr)++dquote :: A.Parser Char+dquote = char doubleQuote++unescape :: A.Parser Text+unescape = (LText.toStrict . Builder.toLazyText) <$!> go mempty where+  go acc = do+    h <- A.takeWhile (/= doubleQuote)+    let rest = do+          c0 <- A.anyChar+          c1 <- A.anyChar+          if (c0 == doubleQuote && c1 == doubleQuote)+              then go (acc `mappend` Builder.fromText h `mappend` Builder.fromText textDoubleQuote)+              else fail "invalid CSV escape sequence"+    done <- A.atEnd+    if done+      then return (acc `mappend` Builder.fromText h)+      else rest++-- | A strict version of 'Data.Functor.<$>' for monads.+(<$!>) :: Monad m => (a -> b) -> m a -> m b+f <$!> m = do+    a <- m+    return $! f a+{-# INLINE (<$!>) #-}++infixl 4 <$!>++-- | A version of 'liftM2' that is strict in the result of its first+-- action.+liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c+liftM2' f a b = do+    !x <- a+    y <- b+    return (f x y)+{-# INLINE liftM2' #-}+++-- | Match either a single newline character @\'\\n\'@, or a carriage+-- return followed by a newline character @\"\\r\\n\"@, or a single+-- carriage return @\'\\r\'@.+endOfLine :: A.Parser ()+endOfLine = (A.char newline *> return ()) <|> (string (Text.pack "\r\n") *> return ()) <|> (A.char cr *> return ())+{-# INLINE endOfLine #-}++textDoubleQuote :: Text+textDoubleQuote = Text.singleton doubleQuote++doubleQuote, newline, cr, comma :: Char+doubleQuote = '\"'+newline = '\n'+cr = '\r'+comma = ','+
+ src/Siphon/Text.hs view
@@ -0,0 +1,33 @@+module Siphon.Text where++import Siphon.Types+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Coerce (coerce)+import qualified Data.Text   as Text+import qualified Data.Vector as Vector++siphon :: Siphon Text+siphon = Siphon escape encodeRow+  (error "siphon: uhoent") (error "siphon: uheokj")++encodeRow :: Vector (Escaped Text) -> Text+encodeRow = id+  . Text.intercalate (Text.singleton ',')+  . Vector.toList+  . coerce++escape :: Text -> Escaped Text+escape t = case Text.find (\c -> c == '\n' || c == ',' || c == '"') t of+  Nothing -> Escaped t+  Just _  -> escapeAlways t++escapeAlways :: Text -> Escaped Text+escapeAlways t = Escaped $ Text.concat+  [ Text.singleton '"'+  , Text.replace (Text.pack "\"") (Text.pack "\"\"") t+  , Text.singleton '"'+  ]+++
+ src/Siphon/Types.hs view
@@ -0,0 +1,45 @@+module Siphon.Types where++import Data.Vector (Vector)+import Colonnade.Types (DecodingRowError)+import qualified Data.Attoparsec.Types as Atto++newtype Escaped c = Escaped { getEscaped :: c }++data Siphon c = Siphon+  { siphonEscape      :: !(c -> Escaped c)+  , siphonIntercalate :: !(Vector (Escaped c) -> c)+  , siphonParseRow    :: c -> Atto.IResult c (Vector c)+  , siphonNull        :: c -> Bool+  }++-- -- | This type is provided for convenience with @pipes-text@+-- data CsvResult f c+--   = CsvResultSuccess+--   | CsvResultTextDecodeError+--   | CsvResultDecodeError (DecodingRowError f c)+--   deriving (Show,Read,Eq)+++-- | Consider changing out the use of 'Vector' here+-- with the humble list instead. It might fuse away+-- better. Not sure though.+-- data SiphonX c1 c2 = SiphonX+--   { siphonXEscape :: !(c1 -> Escaped c2)+--   , siphonXIntercalate :: !(Vector (Escaped c2) -> c2)+--   }+--+-- data SiphonDecoding c1 c2 = SiphonDecoding+--   { siphonDecodingParse :: c1 -> Atto.IResult c1 (Vector c2)+--   , siphonDecodingNull  :: c1 -> Bool+--   }++-- data WithEnd c = WithEnd+--   { withEndEnded :: !Bool+--   , withEndContent :: !c+--   }++-- data SiphonDecodingError+--   { clarify+--   }+
+ test/Test.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric     #-}++module Main (main) where++import Test.QuickCheck                      (Gen, Arbitrary(..), choose, elements)+import Test.HUnit                           (Assertion,(@?=))+import Test.Framework                       (defaultMain, testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Framework.Providers.HUnit       (testCase)+import Data.ByteString                      (ByteString)+import Data.Text                            (Text)+import GHC.Generics                         (Generic)+import Data.Either.Combinators+import Colonnade.Types+import Siphon.Types+import Data.Functor.Identity+import Data.Functor.Contravariant           (contramap)+import Data.Functor.Contravariant.Divisible (divided,conquered)+import qualified Data.Text                  as Text+import qualified Data.ByteString.Builder    as Builder+import qualified Data.ByteString.Lazy       as LByteString+import qualified Data.ByteString            as ByteString+import qualified Data.ByteString.Char8      as BC8+import qualified Colonnade.Decoding         as Decoding+import qualified Colonnade.Encoding         as Encoding+import qualified Colonnade.Decoding.ByteString.Char8 as CDB+import qualified Colonnade.Encoding.ByteString.Char8 as CEB+import qualified Colonnade.Decoding.Text    as CDT+import qualified Colonnade.Encoding.Text    as CET+import qualified Siphon.Encoding            as SE+import qualified Siphon.Decoding            as SD+import qualified Siphon.Content             as SC+import qualified Pipes.Prelude              as Pipes+import Pipes++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests =+  [ testGroup "ByteString encode/decode"+    [ testCase "Headless Encoding (int,char,bool)"+        $ runTestScenario+            SC.byteStringChar8+            SE.pipe+            encodingA+            "4,c,false\n"+    , testProperty "Headless Isomorphism (int,char,bool)"+        $ propIsoPipe $+          (SE.pipe SC.byteStringChar8 encodingA)+          >->+          (void $ SD.headlessPipe SC.byteStringChar8 decodingA)+    , testCase "Headed Encoding (int,char,bool)"+        $ runTestScenario+            SC.byteStringChar8+            SE.headedPipe+            encodingB+            $ ByteString.concat+              [ "number,letter,boolean\n"+              , "4,c,false\n"+              ]+    , testCase "Headed Encoding (int,char,bool) monoidal building"+        $ runTestScenario+            SC.byteStringChar8+            SE.headedPipe+            encodingC+            $ ByteString.concat+              [ "boolean,letter\n"+              , "false,c\n"+              ]+    , testProperty "Headed Isomorphism (int,char,bool)"+        $ propIsoPipe $+          (SE.headedPipe SC.byteStringChar8 encodingB)+          >->+          (void $ SD.headedPipe SC.byteStringChar8 decodingB)+    ]+  , testGroup "Text encode/decode"+    [ testCase "Headless Encoding (int,char,bool)"+        $ runTestScenario+            SC.text+            SE.pipe+            encodingW+            "4,c,false\n"+    , testCase "Headless Encoding (Foo,Foo,Foo)"+        $ runCustomTestScenario+            SC.text+            SE.pipe+            encodingY+            (FooA,FooA,FooC)+            "Simple,Simple,\"More\"\"Escaped,\"\"\"\"Chars\"\n"+    , testProperty "Headless Isomorphism (Foo,Foo,Foo)"+        $ propIsoPipe $+          (SE.pipe SC.text encodingY)+          >->+          (void $ SD.headlessPipe SC.text decodingY)+    ]+  ]++data Foo = FooA | FooB | FooC+  deriving (Generic,Eq,Ord,Show,Read,Bounded,Enum)++instance Arbitrary Foo where+  arbitrary = elements [minBound..maxBound]++fooToString :: Foo -> String+fooToString x = case x of+  FooA -> "Simple"+  FooB -> "With,Escaped\nChars"+  FooC -> "More\"Escaped,\"\"Chars"++encodeFoo :: (String -> c) -> Foo -> c+encodeFoo f = f . fooToString++fooFromString :: String -> Either String Foo+fooFromString x = case x of+  "Simple" -> Right FooA+  "With,Escaped\nChars" -> Right FooB+  "More\"Escaped,\"\"Chars" -> Right FooC+  _ -> Left "failed to decode Foo"++decodeFoo :: (c -> String) -> c -> Either String Foo+decodeFoo f = fooFromString . f++decodingA :: Decoding Headless ByteString (Int,Char,Bool)+decodingA = (,,)+  <$> Decoding.headless CDB.int+  <*> Decoding.headless CDB.char+  <*> Decoding.headless CDB.bool++decodingB :: Decoding Headed ByteString (Int,Char,Bool)+decodingB = (,,)+  <$> Decoding.headed "number" CDB.int+  <*> Decoding.headed "letter" CDB.char+  <*> Decoding.headed "boolean" CDB.bool++encodingA :: Encoding Headless ByteString (Int,Char,Bool)+encodingA = contramap tripleToPairs+  $ divided (Encoding.headless CEB.int)+  $ divided (Encoding.headless CEB.char)+  $ divided (Encoding.headless CEB.bool)+  $ conquered++encodingW :: Encoding Headless Text (Int,Char,Bool)+encodingW = contramap tripleToPairs+  $ divided (Encoding.headless CET.int)+  $ divided (Encoding.headless CET.char)+  $ divided (Encoding.headless CET.bool)+  $ conquered++encodingY :: Encoding Headless Text (Foo,Foo,Foo)+encodingY = contramap tripleToPairs+  $ divided (Encoding.headless $ encodeFoo Text.pack)+  $ divided (Encoding.headless $ encodeFoo Text.pack)+  $ divided (Encoding.headless $ encodeFoo Text.pack)+  $ conquered++decodingY :: Decoding Headless Text (Foo,Foo,Foo)+decodingY = (,,)+  <$> Decoding.headless (decodeFoo Text.unpack)+  <*> Decoding.headless (decodeFoo Text.unpack)+  <*> Decoding.headless (decodeFoo Text.unpack)++encodingB :: Encoding Headed ByteString (Int,Char,Bool)+encodingB = contramap tripleToPairs+  $ divided (Encoding.headed "number" CEB.int)+  $ divided (Encoding.headed "letter" CEB.char)+  $ divided (Encoding.headed "boolean" CEB.bool)+  $ conquered++encodingC :: Encoding Headed ByteString (Int,Char,Bool)+encodingC = mconcat+  [ contramap thd3 $ Encoding.headed "boolean" CEB.bool+  , contramap snd3 $ Encoding.headed "letter" CEB.char+  ]++tripleToPairs :: (a,b,c) -> (a,(b,(c,())))+tripleToPairs (a,b,c) = (a,(b,(c,())))++propIsoPipe :: Eq a => Pipe a a Identity () -> [a] -> Bool+propIsoPipe p as = (Pipes.toList $ each as >-> p) == as++runTestScenario :: (Monoid c, Eq c, Show c)+  => Siphon c+  -> (Siphon c -> Encoding f c (Int,Char,Bool) -> Pipe (Int,Char,Bool) c Identity ())+  -> Encoding f c (Int,Char,Bool)+  -> c+  -> Assertion+runTestScenario s p e c =+  ( mconcat $ Pipes.toList $+    Pipes.yield (4,'c',False) >-> p s e+  ) @?= c++runCustomTestScenario :: (Monoid c, Eq c, Show c)+  => Siphon c+  -> (Siphon c -> Encoding f c a -> Pipe a c Identity ())+  -> Encoding f c a+  -> a+  -> c+  -> Assertion+runCustomTestScenario s p e a c =+  ( mconcat $ Pipes.toList $+    Pipes.yield a >-> p s e+  ) @?= c++-- testEncodingA :: Assertion+-- testEncodingA = runTestScenario encodingA "4,c,false\n"++propEncodeDecodeIso :: Eq a => (a -> b) -> (b -> Maybe a) -> a -> Bool+propEncodeDecodeIso f g a = g (f a) == Just a++propMatching :: Eq b => (a -> b) -> (a -> b) -> a -> Bool+propMatching f g a = f a == g a+++-- | Take the first item out of a 3 element tuple+fst3 :: (a,b,c) -> a+fst3 (a,b,c) = a++-- | Take the second item out of a 3 element tuple+snd3 :: (a,b,c) -> b+snd3 (a,b,c) = b++-- | Take the third item out of a 3 element tuple+thd3 :: (a,b,c) -> c+thd3 (a,b,c) = c+