[Haskell-cafe] Re: Data.Binary stack overflow with Data.Sequence String

[ChrisK]

I have collected some of the backing code to "decode".  This is all pasted below 
so we can look at it.  I will not improperly guess at the cause of the problem, 
and be totally wrong.

I observe Get is a lazy monad:

Prelude Data.Binary Data.Binary.Get Data.Monoid> "World" == runGet ((return $! 
undefined) >> return "World") mempty
True

Prelude Data.Binary Data.Binary.Get Data.Monoid> 'W' == head (runGet ((return $! 
undefined) >>= \t -> return $! ('W':t))  mempty)
True

Prelude Data.Binary Data.Binary.Get Data.Monoid> "orld" == tail (runGet ((return 
$! undefined) >>= \h -> return $! (h:"orld"))  mempty)
True

This may have implication for building the "String" from "Char".  The get for 
"Char" uses "return $! char" but this is no good unless the Char is being 
forced, as the (return $! undefined) above shows.

The instance Get [a] inherits the laziness of replicateM which is sequence.

The instance (Seq.Seq e) does not force the "x :: String" value.  And even if it 
did it would only force the leading (:) cons cell and not the characters 
themselves.  The instance is strict in what passes for the spine of the Seq, not 
the contents, and certainly not the deep contents.

You might try using "newtype" when deserializing ArticleDB and make a much 
stricter version of the code.

All the relevant code (yi & binary & ghc):

> type Article = String
> type ArticleDB = Seq Article
> 
> -- | Read in database from 'dbLocation' and then parse it into an 'ArticleDB'.
> readDB :: YiM ArticleDB
> readDB = io $ (dbLocation >>= r) `catch` (\_ -> return empty)
>           where r x = fmap (decode . BL.fromChunks . return) $ B.readFile x
>                 -- We read in with strict bytestrings to guarantee the file is closed,
>                 -- and then we convert it to the lazy bytestring data.binary expects.
>                 -- This is inefficient, but alas...
> 
> decode :: Binary a => ByteString -> a
> decode = runGet get
> 
> instance (Binary e) => Binary (Seq.Seq e) where
>     put s = put (Seq.length s) >> Fold.mapM_ put s
>     get = do n <- get :: Get Int
>              rep Seq.empty n get
>       where rep xs 0 _ = return $! xs
>             rep xs n g = xs `seq` n `seq` do
>                            x <- g
>                            rep (xs Seq.|> x) (n-1) g
> 
> instance Binary Int where
>     put i   = put (fromIntegral i :: Int64)
>     get     = liftM fromIntegral (get :: Get Int64)
> 
> instance Binary Int64 where
>     put i   = put (fromIntegral i :: Word64)
>     get     = liftM fromIntegral (get :: Get Word64)
> 
> instance Binary Word64 where
>     put     = putWord64be
>     get     = getWord64be
> 
> instance Binary a => Binary [a] where
>     put l  = put (length l) >> mapM_ put l
>     get    = do n <- get :: Get Int
>                 replicateM n get
> 
> -- Char is serialised as UTF-8
> instance Binary Char where
>     put a | c <= 0x7f     = put (fromIntegral c :: Word8)
>           | c <= 0x7ff    = do put (0xc0 .|. y)
>                                put (0x80 .|. z)
>           | c <= 0xffff   = do put (0xe0 .|. x)
>                                put (0x80 .|. y)
>                                put (0x80 .|. z)
>           | c <= 0x10ffff = do put (0xf0 .|. w)
>                                put (0x80 .|. x)
>                                put (0x80 .|. y)
>                                put (0x80 .|. z)
>           | otherwise     = error "Not a valid Unicode code point"
>      where
>         c = ord a
>         z, y, x, w :: Word8
>         z = fromIntegral (c           .&. 0x3f)
>         y = fromIntegral (shiftR c 6  .&. 0x3f)
>         x = fromIntegral (shiftR c 12 .&. 0x3f)
>         w = fromIntegral (shiftR c 18 .&. 0x7)
> 
>     get = do
>         let getByte = liftM (fromIntegral :: Word8 -> Int) get
>             shiftL6 = flip shiftL 6 :: Int -> Int
>         w <- getByte
>         r <- case () of
>                 _ | w < 0x80  -> return w
>                   | w < 0xe0  -> do
>                                     x <- liftM (xor 0x80) getByte
>                                     return (x .|. shiftL6 (xor 0xc0 w))
>                   | w < 0xf0  -> do
>                                     x <- liftM (xor 0x80) getByte
>                                     y <- liftM (xor 0x80) getByte
>                                     return (y .|. shiftL6 (x .|. shiftL6
>                                             (xor 0xe0 w)))
>                   | otherwise -> do
>                                 x <- liftM (xor 0x80) getByte
>                                 y <- liftM (xor 0x80) getByte
>                                 z <- liftM (xor 0x80) getByte
>                                 return (z .|. shiftL6 (y .|. shiftL6
>                                         (x .|. shiftL6 (xor 0xf0 w))))
>         return $! chr r
> 
> 
> replicateM        :: (Monad m) => Int -> m a -> m [a]
> replicateM n x    = sequence (replicate n x)
> 
> sequence       :: Monad m => [m a] -> m [a] 
> {-# INLINE sequence #-}
> sequence ms = foldr k (return []) ms
>             where
>               k m m' = do { x <- m; xs <- m'; return (x:xs) }

-- 
Chris