bind-marshal-0.1: test/verify_desaction_static_fixed_buffer.hs

-- Copyright   :  (C) 2009 Corey O'Connor
-- License     :  BSD-style (see the file LICENSE)

-- If I am not careful the generated constraints can take a *really* long time to discharge.
#define ONLY_SMALL_CASES 0
-- Sometimes compiling the case of 1400 bytes takes over a day. :-(
#define NO_LARGE_CASES 0
#define DISABLE_FLV_CASE 0
import Bind.Marshal.Prelude
import Bind.Marshal.Verify

import Bind.Marshal.Action.Base
import Bind.Marshal.Action.Monad.Static
import Bind.Marshal.Action.Static
import Bind.Marshal.DesAction.Base
import Bind.Marshal.DesAction.Static
import Bind.Marshal.StdLib.Des

import "monads-tf" Control.Monad.Trans

#if !DISABLE_FLV_CASE
import FLVHeader.Data
import FLVHeader.Des
#endif

import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable

import System.IO

t_0 = do 
    static_return ()

t_1 = do 
    y :: Int32 <- des 
    static_return y

t_2 = do
    x :: Int32 <- des
    y :: Int32 <- des
    static_return ( x, y )

t_3 = do
    x :: Int32 <- des
    y :: Int32 <- des
    static_return ()

-- The buffer size in this case is static even though there is a deserialized value dependency:
-- Regardless of the value deserialized the buffer requirement is the same.
t_4 = do
    b :: Word8 <- des
    if b == 0 
        then do
            _ :: Int32 <- des
            static_return ()
        else do
            _ :: Word8 <- des
            _ :: Word8 <- des
            _ :: Word8 <- des
            _ :: Word8 <- des
            static_return ()
    static_return ()

#if !ONLY_SMALL_CASES
t_6 = do
    a0 :: Int32 <- des
    a1 :: Int32 <- des
    a2 :: Int32 <- des
    a3 :: Int32 <- des
    a4 :: Int32 <- des
    a5 :: Int32 <- des
    a6 :: Int32 <- des
    a7 :: Int32 <- des
    a8 :: Int32 <- des
    a9 :: Int32 <- des
    a10 :: Int32 <- des
    a11 :: Int32 <- des
    a12 :: Int32 <- des
    a13 :: Int32 <- des
    a14 :: Int32 <- des
    static_return ( a0 
            + a1
            + a2
            + a3
            + a4
            + a5
            + a6
            + a7
            + a8
            + a9
            + a10
            + a11
            + a12
            + a13
            + a14
            )

t_7 = do
    b0 <- t_6
    b1 <- t_6
    b2 <- t_6
    b3 <- t_6
    b4 <- t_6
    b5 <- t_6
    b6 <- t_6
    b7 <- t_6
    b8 <- t_6
    b9 <- t_6
    static_return ( b0 
            + b1 
            + b2 
            + b3
            + b4
            + b5
            + b6
            + b7
            + b8
            + b9
            )

#if !NO_LARGE_CASES
t_8 = do
    b0 <- t_7
    b1 <- t_7
    b2 <- t_7
    b3 <- t_7
    b4 <- t_7
    b5 <- t_7
    b6 <- t_7
    b7 <- t_7
    b8 <- t_7
    b9 <- t_7
    static_return ( b0 
            + b1 
            + b2 
            + b3
            + b4
            + b5
            + b6
            + b7
            + b8
            + b9
            )
#endif

#endif

buffer_size = 8000

main = run_test $ do
    buffer_0 <- liftIO $ mallocBytes buffer_size :: Test ( Ptr Word8 )
    verify "Deserializes an Int32" $ \ ( i :: Int32 ) -> liftIOResult $ do
        let b = castPtr buffer_0
        poke b i
        let des_buf = BufferRegion buffer_0 4
        (i_des, b_end') <- apply_des_to_fixed_buffer t_1 des_buf
        unless (i_des == i) $ fail $ show i_des ++ " /= " ++ show i :: IO ()
        returnM succeeded :: IO PropertyResult
    verify "Deserializes two Int32s" $ \ (i_0 :: Int32) (i_1 :: Int32) -> liftIOResult $ do
        let b = castPtr buffer_0
        poke b i_0
        let b' = b `plusPtr` 4
        poke b' i_1
        let des_buf = BufferRegion buffer_0 8
        ( (i_0_des, i_1_des), b_end' ) <- apply_des_to_fixed_buffer t_2 des_buf
        unless (i_0_des == i_0) $ fail $ show i_0_des ++ " /= " ++ show i_0 :: IO ()
        unless (i_1_des == i_1) $ fail $ show i_1_des ++ " /= " ++ show i_1 :: IO ()
        returnM succeeded :: IO PropertyResult
    verify "Deserializes two Int32s with no return" $ \ (i_0 :: Int32) (i_1 :: Int32) -> liftIOResult $ do
        let b = castPtr buffer_0
        poke b i_0
        let b' = b `plusPtr` 4
        poke b' i_1
        let des_buf = BufferRegion buffer_0 8
        ( (), b_end' ) <- apply_des_to_fixed_buffer t_3 des_buf
        returnM succeeded :: IO PropertyResult
    verify "Deserializes with a if/then/else" $ liftIOResult $ do
        let des_buf = BufferRegion buffer_0 5
        ( (), b_end' ) <- apply_des_to_fixed_buffer t_4 des_buf
        returnM succeeded :: IO PropertyResult
#if !DISABLE_FLV_CASE
    verify "Deserializes with des_flv_header" $ \ ( h :: FLVHeader ) -> liftIOResult $ do
        poke (castPtr buffer_0) h
        let des_buf = BufferRegion buffer_0 9
        ( _, b_end' ) <- apply_des_to_fixed_buffer des_flv_header des_buf
        returnM succeeded :: IO PropertyResult
#endif
#if !ONLY_SMALL_CASES
    verify1 "Can at least try to deserialize t_7" $ liftIOResult $ do
        let des_buf = BufferRegion buffer_0 buffer_size
        ( sum, des_buf' ) <- apply_des_to_fixed_buffer t_7 des_buf
        print sum
        returnM succeeded :: IO PropertyResult
#if !NO_LARGE_CASES
    verify1 "Can at least try to deserialize t_8" $ liftIOResult $ do
        let des_buf = BufferRegion buffer_0 buffer_size
        ( sum, des_buf' ) <- apply_des_to_fixed_buffer t_8 des_buf
        print sum
        returnM succeeded :: IO PropertyResult
#endif
#endif
    liftIO $ free buffer_0 :: Test()
    returnM () :: Test ()