{-# 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 (liftM)
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 :: t -> Either String t
    -- | Convert from hexadecimal and fail on invalud input.
    unhexM :: MonadFail m => t -> m t
    unhexM = (String -> m t) -> (t -> m t) -> Either String t -> m t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m t
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail t -> m t
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String t -> m t) -> (t -> Either String t) -> t -> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Either String t
forall t. Hex t => t -> Either String t
unhex

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 {p}. Enum p => p -> String
w
        where w :: p -> String
w p
ch = let s :: String
s = String
"0123456789ABCDEF"
                         x :: Int
x = p -> Int
forall a. Enum a => a -> Int
fromEnum p
ch
                     in [String
s String -> Int -> Char
forall a. HasCallStack => [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. HasCallStack => [a] -> Int -> a
!! Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
x Int
16]
    unhex :: String -> Either String String
unhex []      = String -> Either String String
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    unhex (Char
a:Char
b:String
r) = do Int
x <- Char -> Either String Int
c Char
a
                       Int
y <- Char -> Either String Int
c Char
b
                       (String -> String) -> Either String String -> Either String 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]
:) (Either String String -> Either String String)
-> Either String String -> Either String String
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall t. Hex t => t -> Either String t
unhex String
r
    unhex [Char
_]      = String -> Either String String
forall a b. a -> Either a b
Left String
"Non-even length"


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