{-# LANGUAGE BlockArguments, LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module System.TargetEndian (
	-- * To Select According To Endian
	endian ) where

import Language.Haskell.TH (ExpQ, runIO)
import Foreign.Ptr (castPtr)
import Foreign.Marshal (alloca, peekArray)
import Foreign.Storable (poke)
import Data.Word (Word8, Word32)
import System.Environment (lookupEnv)

---------------------------------------------------------------------------

endian :: ExpQ -> ExpQ -> ExpQ
endian :: ExpQ -> ExpQ -> ExpQ
endian ExpQ
el ExpQ
eb = IO (Either String Endian) -> Q (Either String Endian)
forall a. IO a -> Q a
runIO IO (Either String Endian)
targetEndian Q (Either String Endian) -> (Either String Endian -> ExpQ) -> ExpQ
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
	Right Endian
LittleEndian -> ExpQ
el; Right Endian
BigEndian -> ExpQ
eb
	Right Endian
UnknownEndian -> String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Unknown endian"; Left String
emsg -> String -> ExpQ
forall a. HasCallStack => String -> a
error String
emsg

data Endian = LittleEndian | BigEndian | UnknownEndian deriving Int -> Endian -> ShowS
[Endian] -> ShowS
Endian -> String
(Int -> Endian -> ShowS)
-> (Endian -> String) -> ([Endian] -> ShowS) -> Show Endian
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Endian -> ShowS
showsPrec :: Int -> Endian -> ShowS
$cshow :: Endian -> String
show :: Endian -> String
$cshowList :: [Endian] -> ShowS
showList :: [Endian] -> ShowS
Show

targetEndian :: IO (Either String Endian)
targetEndian :: IO (Either String Endian)
targetEndian = String -> IO (Maybe String)
lookupEnv String
"GHC_TARGET_ENDIAN" IO (Maybe String)
-> (Maybe String -> IO (Either String Endian))
-> IO (Either String Endian)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
	Just String
"little-endian" -> Either String Endian -> IO (Either String Endian)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Endian -> IO (Either String Endian))
-> Either String Endian -> IO (Either String Endian)
forall a b. (a -> b) -> a -> b
$ Endian -> Either String Endian
forall a b. b -> Either a b
Right Endian
LittleEndian
	Just String
"big-endian" -> Either String Endian -> IO (Either String Endian)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Endian -> IO (Either String Endian))
-> Either String Endian -> IO (Either String Endian)
forall a b. (a -> b) -> a -> b
$ Endian -> Either String Endian
forall a b. b -> Either a b
Right Endian
BigEndian
	Just String
edn -> Either String Endian -> IO (Either String Endian)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Endian -> IO (Either String Endian))
-> (String -> Either String Endian)
-> String
-> IO (Either String Endian)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String Endian
forall a b. a -> Either a b
Left (String -> IO (Either String Endian))
-> String -> IO (Either String Endian)
forall a b. (a -> b) -> a -> b
$ String
"no such endian: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
edn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
		String
"\tGHC_TARGET_ENDIAN: little-endian or big-endian"
	Maybe String
Nothing -> Endian -> Either String Endian
forall a b. b -> Either a b
Right (Endian -> Either String Endian)
-> IO Endian -> IO (Either String Endian)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Endian
checkEndian

checkEndian :: IO Endian
checkEndian :: IO Endian
checkEndian = (([Word8] -> Endian) -> IO [Word8] -> IO Endian
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr Word32 -> IO [Word8]) -> IO [Word8]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr Word32
p -> Ptr Word32 -> Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word32
p Word32
word32 IO () -> IO [Word8] -> IO [Word8]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Ptr Word8 -> IO [Word8]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
4 (Ptr Word32 -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Word32
p)) \case
	[Word8
4 :: Word8, Word8
3, Word8
2, Word8
1] -> Endian
LittleEndian; [Word8
1, Word8
2, Word8
3, Word8
4] -> Endian
BigEndian
	[Word8]
_ -> Endian
UnknownEndian
	where word32 :: Word32; word32 :: Word32
word32 = Word32
0x01020304