{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}

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

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

-- |
-- Module      :  Data.Hex
-- Copyright   :  (c) Taru Karttunen 2009
-- License     :  BSD-style
-- Maintainer  :  taruti@taruti.net
-- Stability   :  provisional
-- Portability :  portable
--
-- Convert strings into hexadecimal and back.
module Data.Hex (Hex (..)) where

import Control.Monad
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L

-- | 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
    (String -> String) -> m String -> m String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (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]
:) (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> 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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM 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 (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM 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