{-# language DataKinds #-}
{-# language DerivingStrategies #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language GADTSyntax #-}
{-# language KindSignatures #-}
{-# language MagicHash #-}
{-# language RoleAnnotations #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneDeriving #-}
{-# language TypeApplications #-}
{-# language UnboxedTuples #-}
module System.ByteOrder
(
ByteOrder(..)
, Fixed(..)
, Bytes
, FixedOrdering
, toBigEndian
, toLittleEndian
, fromBigEndian
, fromLittleEndian
, targetByteOrder
) where
import Data.Kind (Type)
import Data.Primitive.ByteArray.Unaligned (PrimUnaligned)
import Data.Primitive.Types (Prim)
import Foreign.Ptr (Ptr,castPtr)
import Foreign.Storable (Storable)
import GHC.ByteOrder (ByteOrder(..),targetByteOrder)
import System.ByteOrder.Class (Bytes(..),FixedOrdering,toFixedEndian)
import qualified Data.Primitive.Types as PM
import qualified Data.Primitive.ByteArray.Unaligned as PMU
import qualified Foreign.Storable as FS
fromBigEndian :: Bytes a => a -> a
fromBigEndian = toBigEndian
fromLittleEndian :: Bytes a => a -> a
fromLittleEndian = toLittleEndian
newtype Fixed :: ByteOrder -> Type -> Type where
Fixed :: forall (b :: ByteOrder) (a :: Type). { getFixed :: a } -> Fixed b a
type role Fixed phantom representational
deriving newtype instance Num a => Num (Fixed b a)
deriving newtype instance Real a => Real (Fixed b a)
deriving newtype instance Integral a => Integral (Fixed b a)
deriving newtype instance Ord a => Ord (Fixed b a)
deriving newtype instance Enum a => Enum (Fixed b a)
deriving newtype instance Eq a => Eq (Fixed b a)
instance (FixedOrdering b, Prim a, Bytes a) => Prim (Fixed b a) where
{-# inline sizeOf# #-}
{-# inline alignment# #-}
{-# inline indexByteArray# #-}
{-# inline readByteArray# #-}
{-# inline writeByteArray# #-}
{-# inline setByteArray# #-}
{-# inline indexOffAddr# #-}
{-# inline readOffAddr# #-}
{-# inline writeOffAddr# #-}
{-# inline setOffAddr# #-}
sizeOf# _ = PM.sizeOf# (undefined :: a)
alignment# _ = PM.alignment# (undefined :: a)
indexByteArray# a i = Fixed (toFixedEndian @b (PM.indexByteArray# a i))
readByteArray# a i s0 = case PM.readByteArray# a i s0 of
(# s1, x #) -> (# s1, Fixed (toFixedEndian @b x) #)
writeByteArray# a i (Fixed x) = PM.writeByteArray# a i (toFixedEndian @b x)
setByteArray# a i n (Fixed x) = PM.setByteArray# a i n (toFixedEndian @b x)
indexOffAddr# a i = Fixed (toFixedEndian @b (PM.indexOffAddr# a i))
readOffAddr# a i s0 = case PM.readOffAddr# a i s0 of
(# s1, x #) -> (# s1, Fixed (toFixedEndian @b x) #)
writeOffAddr# a i (Fixed x) = PM.writeOffAddr# a i (toFixedEndian @b x)
setOffAddr# a i n (Fixed x) = PM.setOffAddr# a i n (toFixedEndian @b x)
instance (FixedOrdering b, PrimUnaligned a, Bytes a) => PrimUnaligned (Fixed b a) where
{-# inline indexUnalignedByteArray# #-}
{-# inline readUnalignedByteArray# #-}
{-# inline writeUnalignedByteArray# #-}
indexUnalignedByteArray# a i = Fixed (toFixedEndian @b (PMU.indexUnalignedByteArray# a i))
readUnalignedByteArray# a i s0 = case PMU.readUnalignedByteArray# a i s0 of
(# s1, x #) -> (# s1, Fixed (toFixedEndian @b x) #)
writeUnalignedByteArray# a i (Fixed x) = PMU.writeUnalignedByteArray# a i (toFixedEndian @b x)
instance (FixedOrdering b, Storable a, Bytes a) => Storable (Fixed b a) where
{-# inline sizeOf #-}
{-# inline alignment #-}
{-# inline peekElemOff #-}
{-# inline pokeElemOff #-}
{-# inline peekByteOff #-}
{-# inline pokeByteOff #-}
{-# inline peek #-}
{-# inline poke #-}
sizeOf _ = FS.sizeOf (undefined :: a)
alignment _ = FS.alignment (undefined :: a)
peekElemOff p i = fmap (Fixed . toFixedEndian @b) (FS.peekElemOff (fromFixedPtr p) i)
pokeElemOff p i (Fixed x) = FS.pokeElemOff (fromFixedPtr p) i (toFixedEndian @b x)
peekByteOff p i = fmap (Fixed . toFixedEndian @b) (FS.peekByteOff p i)
pokeByteOff p i (Fixed x) = FS.pokeByteOff p i (toFixedEndian @b x)
peek p = fmap (Fixed . toFixedEndian @b) (FS.peek (fromFixedPtr p))
poke p (Fixed x) = FS.poke (fromFixedPtr p) (toFixedEndian @b x)
fromFixedPtr :: Ptr (Fixed b a) -> Ptr a
{-# inline fromFixedPtr #-}
fromFixedPtr = castPtr