-- |
-- Module      : Basement.Endianness
-- License     : BSD-style
-- Maintainer  : Haskell Foundation
-- Stability   : experimental
-- Portability : portable
--
-- Set endianness tag to a given primitive. This will help for serialising
-- data for protocols (such as the network protocols).
--

{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Basement.Endianness
    (
      ByteSwap
      -- * Big Endian
    , BE(..), toBE, fromBE
      -- * Little Endian
    , LE(..), toLE, fromLE
      -- * System Endianness
    , Endianness(..)
    , endianness
    ) where

import Basement.Compat.Base
import Data.Word (byteSwap16, byteSwap32, byteSwap64)

#if defined(ARCH_IS_LITTLE_ENDIAN) || defined(ARCH_IS_BIG_ENDIAN)
#else
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (castPtr)
import Foreign.Storable (poke, peek)
import Data.Word (Word8, Word32)
import System.IO.Unsafe (unsafePerformIO)
#endif

import Data.Bits


-- #if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN)
-- import Foundation.System.Info (endianness, Endianness(..))
-- #endif

data Endianness =
      LittleEndian
    | BigEndian
    deriving (Endianness -> Endianness -> Bool
(Endianness -> Endianness -> Bool)
-> (Endianness -> Endianness -> Bool) -> Eq Endianness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Endianness -> Endianness -> Bool
== :: Endianness -> Endianness -> Bool
$c/= :: Endianness -> Endianness -> Bool
/= :: Endianness -> Endianness -> Bool
Eq, Int -> Endianness -> ShowS
[Endianness] -> ShowS
Endianness -> String
(Int -> Endianness -> ShowS)
-> (Endianness -> String)
-> ([Endianness] -> ShowS)
-> Show Endianness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Endianness -> ShowS
showsPrec :: Int -> Endianness -> ShowS
$cshow :: Endianness -> String
show :: Endianness -> String
$cshowList :: [Endianness] -> ShowS
showList :: [Endianness] -> ShowS
Show)

-- | Little Endian value
newtype LE a = LE { forall a. LE a -> a
unLE :: a }
  deriving (Int -> LE a -> ShowS
[LE a] -> ShowS
LE a -> String
(Int -> LE a -> ShowS)
-> (LE a -> String) -> ([LE a] -> ShowS) -> Show (LE a)
forall a. Show a => Int -> LE a -> ShowS
forall a. Show a => [LE a] -> ShowS
forall a. Show a => LE a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> LE a -> ShowS
showsPrec :: Int -> LE a -> ShowS
$cshow :: forall a. Show a => LE a -> String
show :: LE a -> String
$cshowList :: forall a. Show a => [LE a] -> ShowS
showList :: [LE a] -> ShowS
Show, LE a -> LE a -> Bool
(LE a -> LE a -> Bool) -> (LE a -> LE a -> Bool) -> Eq (LE a)
forall a. Eq a => LE a -> LE a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => LE a -> LE a -> Bool
== :: LE a -> LE a -> Bool
$c/= :: forall a. Eq a => LE a -> LE a -> Bool
/= :: LE a -> LE a -> Bool
Eq, Typeable, Eq (LE a)
LE a
Eq (LE a) =>
(LE a -> LE a -> LE a)
-> (LE a -> LE a -> LE a)
-> (LE a -> LE a -> LE a)
-> (LE a -> LE a)
-> (LE a -> Int -> LE a)
-> (LE a -> Int -> LE a)
-> LE a
-> (Int -> LE a)
-> (LE a -> Int -> LE a)
-> (LE a -> Int -> LE a)
-> (LE a -> Int -> LE a)
-> (LE a -> Int -> Bool)
-> (LE a -> Maybe Int)
-> (LE a -> Int)
-> (LE a -> Bool)
-> (LE a -> Int -> LE a)
-> (LE a -> Int -> LE a)
-> (LE a -> Int -> LE a)
-> (LE a -> Int -> LE a)
-> (LE a -> Int -> LE a)
-> (LE a -> Int -> LE a)
-> (LE a -> Int)
-> Bits (LE a)
Int -> LE a
LE a -> Bool
LE a -> Int
LE a -> Maybe Int
LE a -> LE a
LE a -> Int -> Bool
LE a -> Int -> LE a
LE a -> LE a -> LE a
forall a.
Eq a =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> a
-> (Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> Bool)
-> (a -> Maybe Int)
-> (a -> Int)
-> (a -> Bool)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int)
-> Bits a
forall a. Bits a => Eq (LE a)
forall a. Bits a => LE a
forall a. Bits a => Int -> LE a
forall a. Bits a => LE a -> Bool
forall a. Bits a => LE a -> Int
forall a. Bits a => LE a -> Maybe Int
forall a. Bits a => LE a -> LE a
forall a. Bits a => LE a -> Int -> Bool
forall a. Bits a => LE a -> Int -> LE a
forall a. Bits a => LE a -> LE a -> LE a
$c.&. :: forall a. Bits a => LE a -> LE a -> LE a
.&. :: LE a -> LE a -> LE a
$c.|. :: forall a. Bits a => LE a -> LE a -> LE a
.|. :: LE a -> LE a -> LE a
$cxor :: forall a. Bits a => LE a -> LE a -> LE a
xor :: LE a -> LE a -> LE a
$ccomplement :: forall a. Bits a => LE a -> LE a
complement :: LE a -> LE a
$cshift :: forall a. Bits a => LE a -> Int -> LE a
shift :: LE a -> Int -> LE a
$crotate :: forall a. Bits a => LE a -> Int -> LE a
rotate :: LE a -> Int -> LE a
$czeroBits :: forall a. Bits a => LE a
zeroBits :: LE a
$cbit :: forall a. Bits a => Int -> LE a
bit :: Int -> LE a
$csetBit :: forall a. Bits a => LE a -> Int -> LE a
setBit :: LE a -> Int -> LE a
$cclearBit :: forall a. Bits a => LE a -> Int -> LE a
clearBit :: LE a -> Int -> LE a
$ccomplementBit :: forall a. Bits a => LE a -> Int -> LE a
complementBit :: LE a -> Int -> LE a
$ctestBit :: forall a. Bits a => LE a -> Int -> Bool
testBit :: LE a -> Int -> Bool
$cbitSizeMaybe :: forall a. Bits a => LE a -> Maybe Int
bitSizeMaybe :: LE a -> Maybe Int
$cbitSize :: forall a. Bits a => LE a -> Int
bitSize :: LE a -> Int
$cisSigned :: forall a. Bits a => LE a -> Bool
isSigned :: LE a -> Bool
$cshiftL :: forall a. Bits a => LE a -> Int -> LE a
shiftL :: LE a -> Int -> LE a
$cunsafeShiftL :: forall a. Bits a => LE a -> Int -> LE a
unsafeShiftL :: LE a -> Int -> LE a
$cshiftR :: forall a. Bits a => LE a -> Int -> LE a
shiftR :: LE a -> Int -> LE a
$cunsafeShiftR :: forall a. Bits a => LE a -> Int -> LE a
unsafeShiftR :: LE a -> Int -> LE a
$crotateL :: forall a. Bits a => LE a -> Int -> LE a
rotateL :: LE a -> Int -> LE a
$crotateR :: forall a. Bits a => LE a -> Int -> LE a
rotateR :: LE a -> Int -> LE a
$cpopCount :: forall a. Bits a => LE a -> Int
popCount :: LE a -> Int
Bits)
instance (ByteSwap a, Ord a) => Ord (LE a) where
    compare :: LE a -> LE a -> Ordering
compare LE a
e1 LE a
e2 = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (LE a -> a
forall a. ByteSwap a => LE a -> a
fromLE LE a
e1) (LE a -> a
forall a. ByteSwap a => LE a -> a
fromLE LE a
e2)

-- | Big Endian value
newtype BE a = BE { forall a. BE a -> a
unBE :: a }
  deriving (Int -> BE a -> ShowS
[BE a] -> ShowS
BE a -> String
(Int -> BE a -> ShowS)
-> (BE a -> String) -> ([BE a] -> ShowS) -> Show (BE a)
forall a. Show a => Int -> BE a -> ShowS
forall a. Show a => [BE a] -> ShowS
forall a. Show a => BE a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> BE a -> ShowS
showsPrec :: Int -> BE a -> ShowS
$cshow :: forall a. Show a => BE a -> String
show :: BE a -> String
$cshowList :: forall a. Show a => [BE a] -> ShowS
showList :: [BE a] -> ShowS
Show, BE a -> BE a -> Bool
(BE a -> BE a -> Bool) -> (BE a -> BE a -> Bool) -> Eq (BE a)
forall a. Eq a => BE a -> BE a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => BE a -> BE a -> Bool
== :: BE a -> BE a -> Bool
$c/= :: forall a. Eq a => BE a -> BE a -> Bool
/= :: BE a -> BE a -> Bool
Eq, Typeable, Eq (BE a)
BE a
Eq (BE a) =>
(BE a -> BE a -> BE a)
-> (BE a -> BE a -> BE a)
-> (BE a -> BE a -> BE a)
-> (BE a -> BE a)
-> (BE a -> Int -> BE a)
-> (BE a -> Int -> BE a)
-> BE a
-> (Int -> BE a)
-> (BE a -> Int -> BE a)
-> (BE a -> Int -> BE a)
-> (BE a -> Int -> BE a)
-> (BE a -> Int -> Bool)
-> (BE a -> Maybe Int)
-> (BE a -> Int)
-> (BE a -> Bool)
-> (BE a -> Int -> BE a)
-> (BE a -> Int -> BE a)
-> (BE a -> Int -> BE a)
-> (BE a -> Int -> BE a)
-> (BE a -> Int -> BE a)
-> (BE a -> Int -> BE a)
-> (BE a -> Int)
-> Bits (BE a)
Int -> BE a
BE a -> Bool
BE a -> Int
BE a -> Maybe Int
BE a -> BE a
BE a -> Int -> Bool
BE a -> Int -> BE a
BE a -> BE a -> BE a
forall a.
Eq a =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> a
-> (Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> Bool)
-> (a -> Maybe Int)
-> (a -> Int)
-> (a -> Bool)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int -> a)
-> (a -> Int)
-> Bits a
forall a. Bits a => Eq (BE a)
forall a. Bits a => BE a
forall a. Bits a => Int -> BE a
forall a. Bits a => BE a -> Bool
forall a. Bits a => BE a -> Int
forall a. Bits a => BE a -> Maybe Int
forall a. Bits a => BE a -> BE a
forall a. Bits a => BE a -> Int -> Bool
forall a. Bits a => BE a -> Int -> BE a
forall a. Bits a => BE a -> BE a -> BE a
$c.&. :: forall a. Bits a => BE a -> BE a -> BE a
.&. :: BE a -> BE a -> BE a
$c.|. :: forall a. Bits a => BE a -> BE a -> BE a
.|. :: BE a -> BE a -> BE a
$cxor :: forall a. Bits a => BE a -> BE a -> BE a
xor :: BE a -> BE a -> BE a
$ccomplement :: forall a. Bits a => BE a -> BE a
complement :: BE a -> BE a
$cshift :: forall a. Bits a => BE a -> Int -> BE a
shift :: BE a -> Int -> BE a
$crotate :: forall a. Bits a => BE a -> Int -> BE a
rotate :: BE a -> Int -> BE a
$czeroBits :: forall a. Bits a => BE a
zeroBits :: BE a
$cbit :: forall a. Bits a => Int -> BE a
bit :: Int -> BE a
$csetBit :: forall a. Bits a => BE a -> Int -> BE a
setBit :: BE a -> Int -> BE a
$cclearBit :: forall a. Bits a => BE a -> Int -> BE a
clearBit :: BE a -> Int -> BE a
$ccomplementBit :: forall a. Bits a => BE a -> Int -> BE a
complementBit :: BE a -> Int -> BE a
$ctestBit :: forall a. Bits a => BE a -> Int -> Bool
testBit :: BE a -> Int -> Bool
$cbitSizeMaybe :: forall a. Bits a => BE a -> Maybe Int
bitSizeMaybe :: BE a -> Maybe Int
$cbitSize :: forall a. Bits a => BE a -> Int
bitSize :: BE a -> Int
$cisSigned :: forall a. Bits a => BE a -> Bool
isSigned :: BE a -> Bool
$cshiftL :: forall a. Bits a => BE a -> Int -> BE a
shiftL :: BE a -> Int -> BE a
$cunsafeShiftL :: forall a. Bits a => BE a -> Int -> BE a
unsafeShiftL :: BE a -> Int -> BE a
$cshiftR :: forall a. Bits a => BE a -> Int -> BE a
shiftR :: BE a -> Int -> BE a
$cunsafeShiftR :: forall a. Bits a => BE a -> Int -> BE a
unsafeShiftR :: BE a -> Int -> BE a
$crotateL :: forall a. Bits a => BE a -> Int -> BE a
rotateL :: BE a -> Int -> BE a
$crotateR :: forall a. Bits a => BE a -> Int -> BE a
rotateR :: BE a -> Int -> BE a
$cpopCount :: forall a. Bits a => BE a -> Int
popCount :: BE a -> Int
Bits)
instance (ByteSwap a, Ord a) => Ord (BE a) where
    compare :: BE a -> BE a -> Ordering
compare BE a
e1 BE a
e2 = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (BE a -> a
forall a. ByteSwap a => BE a -> a
fromBE BE a
e1) (BE a -> a
forall a. ByteSwap a => BE a -> a
fromBE BE a
e2)

-- | Convert a value in cpu endianess to big endian
toBE :: ByteSwap a => a -> BE a
#ifdef ARCH_IS_LITTLE_ENDIAN
toBE :: forall a. ByteSwap a => a -> BE a
toBE = a -> BE a
forall a. a -> BE a
BE (a -> BE a) -> (a -> a) -> a -> BE a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> a
forall a. ByteSwap a => a -> a
byteSwap
#elif ARCH_IS_BIG_ENDIAN
toBE = BE
#else
toBE = BE . (if endianness == LittleEndian then byteSwap else id)
#endif
{-# INLINE toBE #-}

-- | Convert from a big endian value to the cpu endianness
fromBE :: ByteSwap a => BE a -> a
#ifdef ARCH_IS_LITTLE_ENDIAN
fromBE :: forall a. ByteSwap a => BE a -> a
fromBE (BE a
a) = a -> a
forall a. ByteSwap a => a -> a
byteSwap a
a
#elif ARCH_IS_BIG_ENDIAN
fromBE (BE a) = a
#else
fromBE (BE a) = if endianness == LittleEndian then byteSwap a else a
#endif
{-# INLINE fromBE #-}

-- | Convert a value in cpu endianess to little endian
toLE :: ByteSwap a => a -> LE a
#ifdef ARCH_IS_LITTLE_ENDIAN
toLE :: forall a. ByteSwap a => a -> LE a
toLE = a -> LE a
forall a. a -> LE a
LE
#elif ARCH_IS_BIG_ENDIAN
toLE = LE . byteSwap
#else
toLE = LE . (if endianness == LittleEndian then id else byteSwap)
#endif
{-# INLINE toLE #-}

-- | Convert from a little endian value to the cpu endianness
fromLE :: ByteSwap a => LE a -> a
#ifdef ARCH_IS_LITTLE_ENDIAN
fromLE :: forall a. ByteSwap a => LE a -> a
fromLE (LE a
a) = a
a
#elif ARCH_IS_BIG_ENDIAN
fromLE (LE a) = byteSwap a
#else
fromLE (LE a) = if endianness == LittleEndian then a else byteSwap a
#endif
{-# INLINE fromLE #-}

-- | endianness of the current architecture
endianness :: Endianness
#ifdef ARCH_IS_LITTLE_ENDIAN
endianness :: Endianness
endianness = Endianness
LittleEndian
#elif ARCH_IS_BIG_ENDIAN
endianness = BigEndian
#else
-- ! ARCH_IS_UNKNOWN_ENDIAN
endianness = unsafePerformIO $ bytesToEndianness <$> word32ToByte input
  where
    input :: Word32
    input = 0x01020304
{-# NOINLINE endianness #-}

word32ToByte :: Word32 -> IO Word8
word32ToByte word = alloca $ \wordPtr -> do
         poke wordPtr word
         peek (castPtr wordPtr)

bytesToEndianness :: Word8 -> Endianness
bytesToEndianness 1 = BigEndian
bytesToEndianness _ = LittleEndian
#endif

-- | Class of types that can be byte-swapped.
--
-- e.g. Word16, Word32, Word64
class ByteSwap a where
    byteSwap :: a -> a
instance ByteSwap Word16 where
    byteSwap :: Word16 -> Word16
byteSwap = Word16 -> Word16
byteSwap16
instance ByteSwap Word32 where
    byteSwap :: Word32 -> Word32
byteSwap = Word32 -> Word32
byteSwap32
instance ByteSwap Word64 where
    byteSwap :: Word64 -> Word64
byteSwap = Word64 -> Word64
byteSwap64