{-# 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 :: Monad 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 ch :: a
ch = let s :: String
s = "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 16,String
s String -> Int -> Char
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
x 16]
    unhex :: String -> m String
unhex []      = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return []
    unhex (a :: Char
a:b :: Char
b:r :: String
r) = do Int
x <- Char -> m Int
forall (m :: * -> *). Monad m => Char -> m Int
c Char
a
                       Int
y <- Char -> m Int
forall (m :: * -> *). Monad 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
* 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, Monad m) => t -> m t
unhex String
r
    unhex [_]      = String -> m String
forall a. HasCallStack => String -> a
error "Non-even length"


c :: Monad m => Char -> m Int
c :: Char -> m Int
c '0' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 0
c '1' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 1
c '2' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 2
c '3' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 3
c '4' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 4
c '5' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 5
c '6' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 6
c '7' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 7
c '8' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 8
c '9' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 9
c 'A' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 10
c 'B' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 11
c 'C' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 12
c 'D' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 13
c 'E' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 14
c 'F' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 15
c 'a' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 10
c 'b' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 11
c 'c' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 12
c 'd' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 13
c 'e' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 14
c 'f' = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return 15
c _   = String -> m Int
forall a. HasCallStack => String -> a
error "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 x :: 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, Monad 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 x :: 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, Monad m) => t -> m t
unhex (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
L.unpack ByteString
x