File: RoundTrip.hs

package info (click to toggle)
haskell-cereal 0.5.3.0-2
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 160 kB
  • sloc: haskell: 1,545; makefile: 2
file content (63 lines) | stat: -rw-r--r-- 2,603 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
{-# LANGUAGE ExistentialQuantification #-}

--------------------------------------------------------------------------------
-- |
-- Module      : 
-- Copyright   : (c) Galois, Inc, 2009
-- License     : BSD3
--
-- Maintainer  : Trevor Elliott <trevor@galois.com>
-- Stability   : 
-- Portability : 
--
module RoundTrip where

import Data.Serialize
import Data.Serialize.Get
import Data.Serialize.Put
import Data.Serialize.IEEE754
import Data.Word (Word8,Word16,Word32,Word64)
import System.Exit (ExitCode(..), exitSuccess, exitWith)
import Test.QuickCheck as QC

import Test.Framework (Test(),testGroup)
import Test.Framework.Providers.QuickCheck2 (testProperty)


roundTrip :: Eq a => Putter a -> Get a -> a -> Bool
roundTrip p g a = res == Right a
  where res = runGet g (runPut (p a))

-- | Did a call to 'quickCheckResult' succeed?
isSuccess :: QC.Result -> Bool
isSuccess (Success _ _ _) = True
isSuccess _ = False

tests :: Test
tests  = testGroup "Round Trip"
  [ testProperty "Word8        Round Trip" $ roundTrip putWord8      getWord8
  , testProperty "Word16be     Round Trip" $ roundTrip putWord16be   getWord16be
  , testProperty "Word16le     Round Trip" $ roundTrip putWord16le   getWord16le
  , testProperty "Word32be     Round Trip" $ roundTrip putWord32be   getWord32be
  , testProperty "Word32le     Round Trip" $ roundTrip putWord32le   getWord32le
  , testProperty "Word64be     Round Trip" $ roundTrip putWord64be   getWord64be
  , testProperty "Word64le     Round Trip" $ roundTrip putWord64le   getWord64le
  , testProperty "Word16host   Round Trip" $ roundTrip putWord16host getWord16host
  , testProperty "Word32host   Round Trip" $ roundTrip putWord32host getWord32host
  , testProperty "Word64host   Round Trip" $ roundTrip putWord64host getWord64host
  , testProperty "Float32le    Round Trip" $ roundTrip putFloat32le  getFloat32le
  , testProperty "Float32be    Round Trip" $ roundTrip putFloat32be  getFloat32be
  , testProperty "Float64le    Round Trip" $ roundTrip putFloat64le  getFloat64le
  , testProperty "Float64be    Round Trip" $ roundTrip putFloat64be  getFloat64be

    -- Containers
  , testProperty "(Word8,Word8) Round Trip"
    $ roundTrip (putTwoOf putWord8 putWord8) (getTwoOf getWord8 getWord8)
  , testProperty "[Word8] Round Trip"
    $ roundTrip (putListOf putWord8) (getListOf getWord8)
  , testProperty "Maybe Word8 Round Trip"
    $ roundTrip (putMaybeOf putWord8) (getMaybeOf getWord8)
  , testProperty "Either Word8 Word16be Round Trip "
    $ roundTrip (putEitherOf putWord8 putWord16be)
                (getEitherOf getWord8 getWord16be)
  ]