[GHC] #7743: GHCI segfaults with Data.Binary instances

[GHC]

#7743: GHCI segfaults with Data.Binary instances
-----------------------------+----------------------------------------------
Reporter:  BigEndian         |          Owner:                  
    Type:  bug               |         Status:  new             
Priority:  normal            |      Component:  Compiler        
 Version:  7.6.2             |       Keywords:                  
      Os:  Unknown/Multiple  |   Architecture:  Unknown/Multiple
 Failure:  GHCi crash        |      Blockedby:                  
Blocking:                    |        Related:                  
-----------------------------+----------------------------------------------
 The following code seems to crash GHCi

 I apologize for the long test case,
 but I'll need to rebuild ghc with symbols first before I can reduce the
 test case.

 GHCi's output is
 {{{
 eric at sagacity ~/prog/haskell/tasks master > ghci
 GHCi, version 7.6.2: http://www.haskell.org/ghc/  :? for help
 Loading package ghc-prim ... linking ... done.
 Loading package integer-gmp ... linking ... done.
 Loading package base ... linking ... done.
 Prelude> :l Segfault.hs
 [1 of 1] Compiling Main             ( Segfault.hs, interpreted )
 Ok, modules loaded: Main.
 *Main> main
 Loading package array-0.4.0.1 ... linking ... done.
 Loading package deepseq-1.3.0.1 ... linking ... done.
 Loading package bytestring-0.10.0.2 ... linking ... done.
 Loading package containers-0.5.0.0 ... linking ... done.
 Loading package binary-0.5.1.1 ... linking ... done.
 "zsh: segmentation fault  ghci
 }}}

 Related code is
 {{{
 module Main where

 import qualified Data.ByteString as BW
 import Data.Word(Word8(..))
 import Data.Binary
 import Control.Monad
 import Data.Char

 convertWord8ToChar :: Word8 -> Char
 convertWord8ToChar = chr . fromIntegral

 convertCharToWord8 :: Char -> Word8
 convertCharToWord8 = fromIntegral . ord

 stringToWByteString :: String -> BW.ByteString
 stringToWByteString = BW.pack . map convertCharToWord8

 wByteStringToString :: BW.ByteString -> String
 wByteStringToString = map convertWord8ToChar . BW.unpack

 newtype TaskString = TaskString BW.ByteString deriving (Read, Show)

 stringToTaskString :: String -> TaskString
 stringToTaskString = TaskString . stringToWByteString

 word8sToTaskString :: [Word8] -> TaskString
 word8sToTaskString = TaskString . BW.pack

 instance Binary TaskString where
    get = do
             (return . word8sToTaskString . init) =<< readWord8sUntil 0
          where
             readWord8sUntil :: Word8 -> Get [Word8]
             readWord8sUntil val = do
                w8 <- getWord8
                if w8 == val then
                   return $ [w8]
                else
                   (return . (w8:)) =<< (readWord8sUntil val)

    put (TaskString bws) = mapM_ putWord8 $ (BW.unpack bws) ++ [0]

 data Task =
    Task { taskTitle :: TaskString, taskNotes :: TaskString, taskPriority
 :: Int }
       deriving (Read, Show)

 instance Binary Task where
    get = do
             tt <- get :: Get TaskString
             tn <- get :: Get TaskString
 tp <- get :: Get Int
             return Task { taskTitle = tt, taskNotes = tn, taskPriority =
 tp }

    put t = do
             put $ taskTitle t
             put $ taskNotes t
             put $ taskPriority t


 exTaskTitle = stringToTaskString "Do the dishes"
 exTaskNotes = stringToTaskString "Must be done by 12:00 today"
 exTaskPriority = 0
 encTaskTitle = encode exTaskTitle
 decTaskTitle = decode encTaskTitle :: TaskString

 exTask = Task { taskTitle = exTaskTitle,
                 taskNotes = exTaskNotes,
                 taskPriority = exTaskPriority }

 encTask = encode exTask
 decTask = decode encTask :: Task

 main = do
    putStrLn $ show encTask

-- 
Ticket URL: <http://hackage.haskell.org/trac/ghc/ticket/7743>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler