diff --git a/colonnade/src/Colonnade/Decoding.hs b/colonnade/src/Colonnade/Decoding.hs index 509c573..06b3ded 100644 --- a/colonnade/src/Colonnade/Decoding.hs +++ b/colonnade/src/Colonnade/Decoding.hs @@ -25,6 +25,16 @@ headless f = DecodingAp Headless f (DecodingPure id) headed :: content -> (content -> Either String a) -> Decoding Headed content a headed h f = DecodingAp (Headed h) f (DecodingPure id) +indexed :: Int -> (content -> Either String a) -> Decoding (Indexed Headless) content a +indexed ix f = DecodingAp (Indexed ix Headless) f (DecodingPure id) + +maxIndex :: forall f c a. Decoding (Indexed f) c a -> Int +maxIndex = go 0 where + go :: forall b. Int -> Decoding (Indexed f) c b -> Int + go !ix (DecodingPure _) = ix + go !ix1 (DecodingAp (Indexed ix2 _) decode apNext) = + go (max ix1 ix2) apNext + -- | This function uses 'unsafeIndex' to access -- elements of the 'Vector'. uncheckedRunWithRow :: diff --git a/colonnade/src/Colonnade/Types.hs b/colonnade/src/Colonnade/Types.hs index 8864f65..ee0b477 100644 --- a/colonnade/src/Colonnade/Types.hs +++ b/colonnade/src/Colonnade/Types.hs @@ -71,6 +71,7 @@ data RowError f content | RowErrorDecode !(DecodingCellErrors f content) -- ^ Error decoding the content | RowErrorSize !Int !Int -- ^ Wrong number of cells in the row | RowErrorHeading !(HeadingErrors content) + | RowErrorMinSize !Int !Int -- instance (Show (f content), Typeable content) => Exception (DecodingErrors f content) diff --git a/siphon/siphon.cabal b/siphon/siphon.cabal index 7be399a..31e8933 100644 --- a/siphon/siphon.cabal +++ b/siphon/siphon.cabal @@ -33,6 +33,24 @@ library , 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 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + source-repository head type: git location: https://github.com/andrewthad/colonnade diff --git a/siphon/src/Siphon/Decoding.hs b/siphon/src/Siphon/Decoding.hs index 57cd0aa..29aed89 100644 --- a/siphon/src/Siphon/Decoding.hs +++ b/siphon/src/Siphon/Decoding.hs @@ -45,6 +45,7 @@ mkParseError i ctxs msg = id , "]" ] +-- | This is seldom useful but is included for completeness. headlessPipe :: Monad m => SiphonDecoding c1 c2 -> Decoding Headless c2 a @@ -54,6 +55,23 @@ headlessPipe sd decoding = uncheckedPipe requiredLength 0 sd indexedDecoding Not indexedDecoding = Decoding.headlessToIndexed decoding requiredLength = Decoding.length indexedDecoding +indexedPipe :: Monad m + => SiphonDecoding c1 c2 + -> Decoding (Indexed Headless) c2 a + -> Pipe c1 a m (DecodingRowError Headless c2) +indexedPipe sd decoding = do + (firstRow, mleftovers) <- consumeGeneral sd mkParseError + let req = Decoding.maxIndex decoding + vlen = Vector.length firstRow + 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 c2) => SiphonDecoding c1 c2 -> Decoding Headed c2 a @@ -63,7 +81,7 @@ headedPipe sd decoding = do case Decoding.headedToIndexed headers decoding of Left headingErrs -> return (DecodingRowError 0 (RowErrorHeading headingErrs)) Right indexedDecoding -> - let requiredLength = Decoding.length indexedDecoding + let requiredLength = Vector.length headers in uncheckedPipe requiredLength 1 sd indexedDecoding mleftovers diff --git a/siphon/test/Test.hs b/siphon/test/Test.hs new file mode 100644 index 0000000..62591b1 --- /dev/null +++ b/siphon/test/Test.hs @@ -0,0 +1,86 @@ +module Main (main) where + +import Test.QuickCheck (Gen, Arbitrary(..), choose) +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Data.ByteString (ByteString) +import Data.Either.Combinators +import Colonnade.Types +import Data.Functor.Contravariant (contramap) +import Data.Functor.Contravariant.Divisible (divided,conquered) +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 + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = [] + [ testGroup "ByteString encode/decode" + [ testProperty "Headless Isomorphism (int,char,bool)" + $ propEncodeDecodeIso + (ipv4ToTextNaive) + (ipv4FromTextNaive) + ] + ] + + +byteStringDecodeInt :: ByteString -> Either String Int +byteStringDecodeInt b = do + (a,bsRem) <- maybe (Left "could not parse int") Right (BC8.readInt b) + if ByteString.null bsRem + then Right a + else Left "found extra characters after int" + +byteStringDecodeChar :: ByteString -> Either String Char +byteStringDecodeChar b = case BC8.length b of + 1 -> Right (BC8.head b) + 0 -> Left "cannot decode Char from empty bytestring" + _ -> Left "cannot decode Char from multi-character bytestring" + +byteStringDecodeBool :: ByteString -> Either String Bool +byteStringDecodeBool b + | b == BC8.pack "true" = Right True + | b == BC8.pack "false" = Right False + | otherwise = Left "must be true or false" + +byteStringEncodeChar :: Char -> ByteString +byteStringEncodeChar = BC8.singleton + +byteStringEncodeInt :: Int -> ByteString +byteStringEncodeInt = LByteString.toStrict + . Builder.toLazyByteString + . Builder.intDec + +byteStringEncodeBool :: Bool -> ByteString +byteStringEncodeBool x = case x of + True -> BC8.pack "true" + False -> BC8.pack "false" + + +decodingA :: Decoding Headless ByteString (Int,Char,Bool) +decodingA = (,,) + <$> Decoding.headless byteStringDecodeInt + <*> Decoding.headless byteStringDecodeChar + <*> Decoding.headless byteStringDecodeBool + +encodingA :: Encoding Headless ByteString (Int,Char,Bool) +encodingA = contramap tripleToPairs + $ divided (Encoding.headless byteStringEncodeInt) + $ divided (Encoding.headless byteStringEncodeChar) + $ divided (Encoding.headless byteStringEncodeBool) + $ conquered + +tripleToPairs :: (a,b,c) -> (a,(b,(c,()))) +tripleToPairs (a,b,c) = (a,(b,(c,()))) + +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 +