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

{-# LANGUAGE NoRebindableSyntax #-}
{-# LANGUAGE ImplicitPrelude #-}
{- I think using a combinatorial species module would vastly simplify this code.  Unfortunately I
 - just don't know enough about coninatorial species to effectively use a module implementing them.
 -
 -}
module ArbMarshal where

import Verify hiding ( Property )

import Control.Applicative
import Control.DeepSeq
import Control.Monad

import Data.Monoid
import Data.Word

{- A description of a large set of static marshals.
 - These are generated by induction on the size of the static marshal. Obviously the generation
 - should not be complete. Even for sizes of 1 there are 256 (static value) + 1 (variable hole) =
 - 257 possibilities.
 - The holes in these marshals have a type (with a static size) and a byte offset location. No hole
 - overlaps and they are listed in increasing offset order.
 -
 - Each static marshal has an associated data value and byte string. The byte string deserialized to
 - the data value and the data value serializes to the byte string. 
 -
 - The variable holes are paired up with values. These are paired with the static bytes to form the
 - actualy bytes.
 -}
data StaticStructure = StaticStructure
    -- consecutive properties. A property is either a value or a hole
    { properties :: [Property]
    }
    deriving (Eq, Show)

instance NFData StaticStructure where
    rnf (StaticStructure properties) = rnf properties

class ByteSize v where
    byte_size :: v -> Int

total_size = sum . map byte_size

instance ByteSize StaticStructure where
    byte_size (StaticStructure properties) = total_size properties

data Property 
    = Value Value
    | Hole
    { byte_offset :: Int
    , hole_type :: HoleType
    }
    deriving (Eq, Show)

instance NFData Property where
    rnf (Value v) = rnf v
    rnf (Hole o t) = rnf o `seq` rnf t

instance ByteSize Property where
    byte_size (Value value) = byte_size value
    byte_size (Hole _ hole_type) = byte_size hole_type

hole_count :: StaticStructure -> Int
hole_count (StaticStructure props) = length [ h | Hole _ h <- props ]

data HoleType 
    = Word8Hole
    | Word16Hole
    | Word32Hole
    deriving (Eq, Show)

instance NFData HoleType where
    rnf Word8Hole = ()
    rnf Word16Hole = ()
    rnf Word32Hole = ()
    
instance ByteSize HoleType where
    byte_size Word8Hole = 1
    byte_size Word16Hole = 2
    byte_size Word32Hole = 4

data Value 
    = Word8Value !Word8
    | Word16Value !Word16
    | Word32Value !Word32
    deriving (Eq, Show)

instance NFData Value where
    rnf (Word8Value _) = ()
    rnf (Word16Value _) = ()
    rnf (Word32Value _) = ()

type_for_value :: Value -> HoleType
type_for_value (Word8Value _) = Word8Hole
type_for_value (Word16Value _) = Word16Hole
type_for_value (Word32Value _) = Word32Hole

instance ByteSize Value where
    byte_size (Word8Value _ ) = 1 
    byte_size (Word16Value _ ) = 2
    byte_size (Word32Value _ ) = 4

-- A specific value is a static marshal paired with values for the holes and a bytestring.
data StaticStructureValue = StaticStructureValue
    { static_structure :: StaticStructure
    , hole_values :: [Value]
    } 
    deriving (Eq, Show)

instance NFData StaticStructureValue where
    rnf (StaticStructureValue s vs) = rnf s `seq` rnf vs

instance Arbitrary Value where
    arbitrary = 
        oneof [ Word8Value <$> arbitrary
              , Word16Value <$> arbitrary
              , Word32Value <$> arbitrary
              ]

-- This should be sufficient to generate:
--  - a static serialization procedure
--  - the arguments for a static serialization procedure
--  - the bytes expected from a static serialization procedure when applied to a given set of
--  arguments.
--  - the value expected when a deserialization procedure is applied to the given bytes.

-- There is one twist: The serialization and deserialization procedures, being static, have to be
-- generated into haskell modules BEFORE the tests are run. 

hole_for_value :: Int -> Value -> Property
hole_for_value byte_offset (Word8Value _) = Hole byte_offset Word8Hole
hole_for_value byte_offset (Word16Value _) = Hole byte_offset Word16Hole
hole_for_value byte_offset (Word32Value _) = Hole byte_offset Word32Hole

instance Arbitrary Property where
    arbitrary = do
        value <- arbitrary
        is_hole <- arbitrary
        if is_hole
            then return $ hole_for_value 0 value 
            else return $ Value value

update_offsets :: [Property] -> [Property]
update_offsets props = update_offsets' 0 props

update_offsets' :: Int -> [Property] -> [Property]
update_offsets' byte_offset [] 
    = []
update_offsets' byte_offset (Value v : props) 
    = Value v            : update_offsets' (byte_size v + byte_offset) props
update_offsets' byte_offset (Hole _ t : props) 
    = Hole byte_offset t : update_offsets' (byte_size t + byte_offset) props

instance Arbitrary StaticStructure where
    arbitrary = do
        raw_properties <- listOf1 (arbitrary :: Gen Property)
        return $ StaticStructure $ update_offsets raw_properties

instance Arbitrary StaticStructureValue where
    arbitrary = do
        structure <- arbitrary
        values <- arbitrary_values structure
        return $ StaticStructureValue structure values 

arbitrary_values structure = do
    let holes = [ h | h@(Hole _ _) <- properties structure ]
    forM holes $ \h -> case hole_type h of
                                Word8Hole -> Word8Value <$> arbitrary 
                                Word16Hole -> Word16Value <$> arbitrary 
                                Word32Hole -> Word32Value <$> arbitrary 

ssv_for_ss structure = do
    values <- single_arbitrary (arbitrary_values structure)
    return $ StaticStructureValue structure values

instance ByteSize StaticStructureValue where
    byte_size = byte_size . static_structure

{- A description of a large set of dynamic marshals. 
 - This description is what is deserialized from the marshal bytes and is what the description
 - serializes to.
 - The goal is to generate an arbitrary description and corresponding bytes that covers a lot of the
 - domain of dynamic memory actions. 
 -}