module Data.Serialize.References
(
BuildM, toLazyByteString,
Region, newRegion,
Label, label, makeLabel, placeLabel,
reference, reference', Size(..), sizeToBytes, ByteOrder(..),
offset',
emitWord8, emitWord8s,
emitWord16le, emitWord16be, emitWord16host,
emitWord32le, emitWord32be, emitWord32host,
emitWord64le, emitWord64be, emitWord64host,
emitInt8, emitInt8s,
emitInt16le, emitInt16be, emitInt16host,
emitInt32le, emitInt32be, emitInt32host,
emitInt64le, emitInt64be, emitInt64host,
emitByteString, emitLazyByteString,
emitStorable, emitStorableList,
padTo, alignedLabel
)
where
import Blaze.ByteString.Builder hiding ( toLazyByteString )
import Control.Applicative
import Control.Monad
import Control.Monad.ST
import Data.Array.Base
import Data.Bits ( shiftL )
import Data.Int
import Data.Monoid
import Data.Word
import Foreign.Storable
import qualified Blaze.ByteString.Builder as Blaze
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
import qualified Data.IntMap as IM
newtype BuildM a = BuildM
{ unBuildM :: forall r.
IM.IntMap RegionContent
-> NextRegion
-> NextLabel
-> (IM.IntMap RegionContent
-> NextRegion
-> NextLabel
-> a
-> r)
-> r }
instance Monad BuildM where
return a = BuildM $ \s nr nl k -> k s nr nl a
BuildM f >>= kont = BuildM $ \s nr nl k ->
f s nr nl (\s' nr' nl' a -> unBuildM (kont a) s' nr' nl' k)
instance Functor BuildM where fmap = liftM
instance Applicative BuildM where pure = return; (<*>) = ap
newtype Label = Label Int
deriving (Eq, Ord)
newtype Region = Region { regionToInt :: Int }
deriving (Eq, Ord)
instance Show Region where
show (Region r) = "<region" ++ show r ++ ">"
instance Show Label where
show (Label l) = "<label" ++ show l ++ ">"
data Size = S1 | S2 | S4 | S8
| S1NoRC
| S2NoRC
deriving (Eq, Show, Ord, Enum)
sizeToBytes :: Size -> Int
sizeToBytes S1NoRC = 1
sizeToBytes S2NoRC = 2
sizeToBytes s = 1 `shiftL` fromEnum s
type NextRegion = Int
type NextLabel = Int
data ByteOrder
= Host
| LE
| BE
data RegionContent = RegionContent
{ rcItems :: [RegionItem]
, rcSize :: !Int
}
data RegionItem
= DataItem Builder !Int
| LabelItem Label
| LabelRef Label ByteOrder Size (Int -> Int)
| LabelOffs Label Label ByteOrder Size (Int -> Int)
emptyRegionContent :: RegionContent
emptyRegionContent =
RegionContent { rcItems = [], rcSize = 0 }
newRegion :: BuildM Region
newRegion = BuildM $ \s n nl k ->
let !n' = n + 1 in
k (IM.insert n emptyRegionContent s) n' nl (Region n)
genLabel :: BuildM Label
genLabel = BuildM $ \s nr nl k ->
let !nl' = nl + 1 in k s nr nl' (Label nl)
withRegion :: Region -> (RegionContent -> RegionContent) -> BuildM ()
withRegion rgn@(Region r) f = BuildM $ \s nr nl k ->
let !s' = IM.alter do_it r s in k s' nr nl ()
where
do_it Nothing = error $ "Non-existing region: " ++ show rgn
do_it (Just c) = let !c' = f c in Just c'
getRegion :: Region -> BuildM RegionContent
getRegion rgn@(Region r) = BuildM $ \s nr nl k ->
case IM.lookup r s of
Nothing -> error $ "Non-existing region: " ++ show rgn
Just c -> k s nr nl c
emit_ :: Region -> Builder -> Int -> BuildM ()
emit_ r bld !sz = withRegion r $ \c ->
case rcItems c of
DataItem b n : rest ->
c{ rcItems = DataItem (b `mappend` bld) (n + sz) : rest,
rcSize = rcSize c + sz }
items ->
c{ rcItems = DataItem bld sz : items,
rcSize = rcSize c + sz }
emitWord8 :: Region -> Word8 -> BuildM ()
emitWord8 r w = emit_ r (fromWord8 w) 1
emitWord8s :: Region -> [Word8] -> BuildM ()
emitWord8s r ws = emit_ r (fromWord8s ws) (length ws)
emitWord16le :: Region -> Word16 -> BuildM ()
emitWord16le r w = emit_ r (fromWord16le w) 2
emitWord16be :: Region -> Word16 -> BuildM ()
emitWord16be r w = emit_ r (fromWord16be w) 2
emitWord16host :: Region -> Word16 -> BuildM ()
emitWord16host r w = emit_ r (fromWord16host w) 2
emitWord32le :: Region -> Word32 -> BuildM ()
emitWord32le r w = emit_ r (fromWord32le w) 4
emitWord32be :: Region -> Word32 -> BuildM ()
emitWord32be r w = emit_ r (fromWord32be w) 4
emitWord32host :: Region -> Word32 -> BuildM ()
emitWord32host r w = emit_ r (fromWord32host w) 4
emitWord64le :: Region -> Word64 -> BuildM ()
emitWord64le r w = emit_ r (fromWord64le w) 8
emitWord64be :: Region -> Word64 -> BuildM ()
emitWord64be r w = emit_ r (fromWord64be w) 8
emitWord64host :: Region -> Word64 -> BuildM ()
emitWord64host r w = emit_ r (fromWord64host w) 8
emitInt8 :: Region -> Int8 -> BuildM ()
emitInt8 r w = emit_ r (fromInt8 w) 1
emitInt8s :: Region -> [Int8] -> BuildM ()
emitInt8s r ws = emit_ r (fromInt8s ws) (length ws)
emitInt16le :: Region -> Int16 -> BuildM ()
emitInt16le r w = emit_ r (fromInt16le w) 2
emitInt16be :: Region -> Int16 -> BuildM ()
emitInt16be r w = emit_ r (fromInt16be w) 2
emitInt16host :: Region -> Int16 -> BuildM ()
emitInt16host r w = emit_ r (fromInt16host w) 2
emitInt32le :: Region -> Int32 -> BuildM ()
emitInt32le r w = emit_ r (fromInt32le w) 4
emitInt32be :: Region -> Int32 -> BuildM ()
emitInt32be r w = emit_ r (fromInt32be w) 4
emitInt32host :: Region -> Int32 -> BuildM ()
emitInt32host r w = emit_ r (fromInt32host w) 4
emitInt64le :: Region -> Int64 -> BuildM ()
emitInt64le r w = emit_ r (fromInt64le w) 8
emitInt64be :: Region -> Int64 -> BuildM ()
emitInt64be r w = emit_ r (fromInt64be w) 8
emitInt64host :: Region -> Int64 -> BuildM ()
emitInt64host r w = emit_ r (fromInt64host w) 8
emitByteString :: Region -> S.ByteString -> BuildM ()
emitByteString r b = emit_ r (fromByteString b) (S.length b)
emitLazyByteString :: Region -> L.ByteString -> BuildM ()
emitLazyByteString r b =
emit_ r (fromLazyByteString b) (fromIntegral (L.length b))
emitStorable :: Storable a => Region -> a -> BuildM ()
emitStorable r a = emit_ r (fromStorable a) (sizeOf a)
emitStorableList :: Storable a => Region -> [a] -> BuildM ()
emitStorableList _ [] = return ()
emitStorableList r as@(a:_) =
emit_ r (fromStorables as) (length as * sizeOf a)
label :: Region -> BuildM Label
label r = do l <- makeLabel; placeLabel r l; return l
makeLabel :: BuildM Label
makeLabel = genLabel
placeLabel :: Region -> Label -> BuildM ()
placeLabel r l =
withRegion r $ \c ->
c{ rcItems = LabelItem l : rcItems c }
padTo :: Region
-> Int
-> Word8
-> BuildM ()
padTo r align byte = do
sz <- rcSize <$> getRegion r
let !padding = sz `rem` align
when (padding > 0) $
emitWord8s r (replicate padding byte)
alignedLabel :: Region -> Int -> BuildM Label
alignedLabel r align = do
padTo r align 0
label r
reference :: Size
-> ByteOrder
-> Region
-> Label
-> BuildM ()
reference sz bo r l = reference' sz bo id r l
reference' :: Size
-> ByteOrder
-> (Int -> Int)
-> Region
-> Label
-> BuildM ()
reference' sz bo f r l =
withRegion r $ \c ->
c{ rcItems = LabelRef l bo sz f : rcItems c,
rcSize = rcSize c + sizeToBytes sz }
offset' :: Size
-> ByteOrder
-> (Int -> Int)
-> Region
-> Label
-> Label
-> BuildM ()
offset' sz bo f r l1 l2 =
withRegion r $ \c ->
c{ rcItems = LabelOffs l1 l2 bo sz f : rcItems c,
rcSize = rcSize c + sizeToBytes sz }
toLazyByteString ::
([Region] -> [Region])
-> BuildM ()
-> L.ByteString
toLazyByteString order build =
unBuildM build IM.empty 0 0 ( \regions _nextRegion numLabels _ ->
let ~(bytes, refs) =
runST (do
let regions_ordered = order (map Region (IM.keys regions))
label_locs <- mkLabelPositions numLabels
let
go [] !_ out [] = do
arr <- unsafeFreezeSTUArray label_locs
return (out, arr)
go [] !sz out (rc:rcs) =
go (reverse (rcItems rc)) sz out rcs
go (item:items) !sz out rcs =
case item of
DataItem b sz' ->
go items (sz + sz') (out `mappend` b) rcs
LabelItem (Label l) -> do
writeArray label_locs l sz
go items sz out rcs
LabelRef (Label l) bo sz' f -> do
let ~target = refs ! l
go items (sz + sizeToBytes sz')
(out `mappend`
writeRef bo sz' (if target /= (1) then f (target sz)
else dangling (Label l) sz))
rcs
LabelOffs (Label l1) (Label l2) bo sz' f ->
let ~source = refs ! l1
~target = refs ! l2
in go items (sz + sizeToBytes sz')
(out `mappend`
writeRef bo sz'
(if target == (1) then dangling (Label l2) sz else
if source == (1) then dangling (Label l1) sz else
f (target source)))
rcs
let contents = map ((regions IM.!) . regionToInt) regions_ordered
go [] 0 mempty contents)
in Blaze.toLazyByteString bytes)
where
mkLabelPositions :: Int -> ST s (STUArray s Int Int)
mkLabelPositions numLabels =
newArray (0, numLabels 1) (1 :: Int)
dangling :: Label -> Int -> a
dangling l sz =
error $ "Reference to unplaced " ++ show l ++
" at offset " ++ show sz
writeRef :: ByteOrder -> Size -> Int -> Builder
writeRef _ S1 offs | 128 <= offs && offs <= 127 =
fromWrite (writeInt8 (fromIntegral offs))
writeRef _ S1NoRC offs =
fromWrite (writeInt8 (fromIntegral offs))
writeRef bo S2 offs | 32768 <= offs && offs <= 32767 =
case bo of
LE -> fromWrite (writeInt16le (fromIntegral offs))
BE -> fromWrite (writeInt16be (fromIntegral offs))
Host -> fromWrite (writeInt16host (fromIntegral offs))
writeRef bo S2NoRC offs =
case bo of
LE -> fromWrite (writeInt16le (fromIntegral offs))
BE -> fromWrite (writeInt16be (fromIntegral offs))
Host -> fromWrite (writeInt16host (fromIntegral offs))
writeRef bo S4 offs =
case bo of
LE -> fromWrite (writeInt32le (fromIntegral offs))
BE -> fromWrite (writeInt32be (fromIntegral offs))
Host -> fromWrite (writeInt32host (fromIntegral offs))
writeRef bo S8 offs =
case bo of
LE -> fromWrite (writeInt64le (fromIntegral offs))
BE -> fromWrite (writeInt64be (fromIntegral offs))
Host -> fromWrite (writeInt64host (fromIntegral offs))
writeRef _ s offs =
error $ "Target (" ++ show offs ++ ") out ouf range for size " ++ show s