{-# LANGUAGE DataKinds #-}

module Ivory.Serialize.Struct (
  labelPackRep,
  PackLabel, packLabel, packLabel',
  packStruct
) where

import Ivory.Language
import Ivory.Serialize.Atoms
import Ivory.Serialize.PackRep

labelPackRep :: Packable t => Label sym t -> PackRep t
labelPackRep _ = packRep

newtype PackLabel sym = PackLabel (PackRep ('Struct sym))

packLabel :: (IvoryStruct sym, IvoryArea t, Packable t) => Label sym t -> PackLabel sym
packLabel label = packLabel' label $ labelPackRep label

packLabel' :: (IvoryStruct sym, IvoryArea t) => Label sym t -> PackRep t -> PackLabel sym
packLabel' label rep = PackLabel $ PackRep
  { packGetLE = \ buf offs str -> packGetLE rep buf offs (str ~> label)
  , packGetBE = \ buf offs str -> packGetBE rep buf offs (str ~> label)
  , packSetLE = \ buf offs str -> packSetLE rep buf offs (str ~> label)
  , packSetBE = \ buf offs str -> packSetBE rep buf offs (str ~> label)
  , packSize = packSize rep
  }

packStruct :: [PackLabel sym] -> PackRep ('Struct sym)
packStruct labels = PackRep
  { packGetLE = foldPackLabels packGetLE labels
  , packGetBE = foldPackLabels packGetBE labels
  , packSetLE = foldPackLabels packSetLE labels
  , packSetBE = foldPackLabels packSetBE labels
  , packSize = sum $ map (\ (PackLabel rep) -> packSize rep) labels
  }

foldPackLabels :: Monad m
               => (PackRep ('Struct str) -> buf -> Uint32 -> strref -> m ())
               -> [PackLabel str] -> buf -> Uint32 -> strref
               -> m ()
foldPackLabels f labels buf base str = foldl once (return 0) labels >> return ()
  where
  once m (PackLabel rep) = do
    offs <- m
    f rep buf (base + fromInteger offs) str
    return $! offs + packSize rep