{-# LANGUAGE CPP                  #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-
 This module is copied from @hex@ module (https://github.com/taruti/haskell-hex),
 because it is not supported and was removed from stackage.
-}
module Data.PackStream.Internal.Hex (Hex(..)) where

import qualified Data.ByteString.Char8      as B
import qualified Data.ByteString.Lazy.Char8 as L
#if !MIN_VERSION_base(4, 13, 0)
import Control.Monad.Fail (MonadFail)
#endif

-- | Convert strings into hexadecimal and back.
class Hex t where
    -- | Convert string into hexadecimal.
    hex   :: t -> t
    -- | Convert from hexadecimal and fail on invalid input.
    unhex :: MonadFail m => t -> m t


instance Hex String where
    hex :: String -> String
hex = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
Prelude.concatMap Char -> String
forall a. Enum a => a -> String
w
        where w :: a -> String
w a
ch = let s :: String
s = String
"0123456789ABCDEF"
                         x :: Int
x = a -> Int
forall a. Enum a => a -> Int
fromEnum a
ch
                     in [String
s String -> Int -> Char
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
x Int
16,String
s String -> Int -> Char
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
x Int
16]
    unhex :: String -> m String
unhex []      = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return []
    unhex (Char
a:Char
b:String
r) = do Int
x <- Char -> m Int
forall (m :: * -> *). MonadFail m => Char -> m Int
c Char
a
                       Int
y <- Char -> m Int
forall (m :: * -> *). MonadFail m => Char -> m Int
c Char
b
                       (Int -> Char
forall a. Enum a => Int -> a
toEnum ((Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y) Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m String
forall t (m :: * -> *). (Hex t, MonadFail m) => t -> m t
unhex String
r
    unhex [Char
_]      = String -> m String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Non-even length"


c :: MonadFail m => Char -> m Int
c :: Char -> m Int
c Char
'0' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
c Char
'1' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1
c Char
'2' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
2
c Char
'3' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
3
c Char
'4' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
4
c Char
'5' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
5
c Char
'6' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
6
c Char
'7' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
7
c Char
'8' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
8
c Char
'9' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
9
c Char
'A' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
10
c Char
'B' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
11
c Char
'C' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
12
c Char
'D' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
13
c Char
'E' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
14
c Char
'F' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
15
c Char
'a' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
10
c Char
'b' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
11
c Char
'c' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
12
c Char
'd' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
13
c Char
'e' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
14
c Char
'f' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
15
c Char
_   = String -> m Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid hex digit!"

instance Hex B.ByteString where
    hex :: ByteString -> ByteString
hex = String -> ByteString
B.pack (String -> ByteString)
-> (ByteString -> String) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall t. Hex t => t -> t
hex (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack
    unhex :: ByteString -> m ByteString
unhex ByteString
x = (String -> ByteString) -> m String -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ByteString
B.pack (m String -> m ByteString) -> m String -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> m String
forall t (m :: * -> *). (Hex t, MonadFail m) => t -> m t
unhex (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B.unpack ByteString
x

instance Hex L.ByteString where
    hex :: ByteString -> ByteString
hex = String -> ByteString
L.pack (String -> ByteString)
-> (ByteString -> String) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall t. Hex t => t -> t
hex (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
L.unpack
    unhex :: ByteString -> m ByteString
unhex ByteString
x = (String -> ByteString) -> m String -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ByteString
L.pack (m String -> m ByteString) -> m String -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> m String
forall t (m :: * -> *). (Hex t, MonadFail m) => t -> m t
unhex (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
L.unpack ByteString
x