{-# LANGUAGE DeriveDataTypeable #-}
{- | This implements BootString en- and decoding, the foundation of Punycode
 -}
module Data.Encoding.BootString
	(BootString(..)
	,punycode) where

import Data.Encoding.Base
import Data.Encoding.Exception
import Data.Encoding.ByteSource
import Data.Encoding.ByteSink
import Control.Throws
import Data.Word
import Data.List (unfoldr,partition,find)
import Data.Char (ord,chr)
import Data.Typeable
import Control.Monad (when)

data BootString = BootString
	{BootString -> Int
base :: Int
	,BootString -> Int
tmin :: Int
	,BootString -> Int
tmax :: Int
	,BootString -> Int
skew :: Int
	,BootString -> Int
damp :: Int
	,BootString -> Int
init_bias :: Int
	,BootString -> Int
init_n    :: Int
	}
	deriving (Int -> BootString -> ShowS
[BootString] -> ShowS
BootString -> String
(Int -> BootString -> ShowS)
-> (BootString -> String)
-> ([BootString] -> ShowS)
-> Show BootString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BootString -> ShowS
showsPrec :: Int -> BootString -> ShowS
$cshow :: BootString -> String
show :: BootString -> String
$cshowList :: [BootString] -> ShowS
showList :: [BootString] -> ShowS
Show,BootString -> BootString -> Bool
(BootString -> BootString -> Bool)
-> (BootString -> BootString -> Bool) -> Eq BootString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BootString -> BootString -> Bool
== :: BootString -> BootString -> Bool
$c/= :: BootString -> BootString -> Bool
/= :: BootString -> BootString -> Bool
Eq,Typeable)

punycode :: BootString
punycode :: BootString
punycode = BootString
	{base :: Int
base = Int
36
	,tmin :: Int
tmin = Int
1
	,tmax :: Int
tmax = Int
26
	,skew :: Int
skew = Int
38
	,damp :: Int
damp = Int
700
	,init_bias :: Int
init_bias = Int
72
	,init_n :: Int
init_n    = Int
0x80
	}

punyValue :: ByteSource m => Word8 -> m Int
punyValue :: forall (m :: * -> *). ByteSource m => Word8 -> m Int
punyValue Word8
c
	| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
0x30 = m Int
forall {a}. m a
norep
	| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x39 = Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
0x30Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
26
	| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
0x41 = m Int
forall {a}. m a
norep
	| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x5A = Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
0x41
	| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
0x61 = m Int
forall {a}. m a
norep
	| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x7A = Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
0x61
	| Bool
otherwise = m Int
forall {a}. m a
norep
	where
	n :: Int
n = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c
	norep :: m a
norep = DecodingException -> m a
forall a. DecodingException -> m a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException (Word8 -> DecodingException
IllegalCharacter Word8
c)

punyChar :: ByteSink m => Int -> m Word8
punyChar :: forall (m :: * -> *). ByteSink m => Int -> m Word8
punyChar Int
c
	| Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0  = m Word8
forall {a}. m a
norep
	| Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
26 = Word8 -> m Word8
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> m Word8) -> Word8 -> m Word8
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
0x61Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
c
	| Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
36 = Word8 -> m Word8
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> m Word8) -> Word8 -> m Word8
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
0x30Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
26
	| Bool
otherwise = m Word8
forall {a}. m a
norep
	where
	norep :: m a
norep = EncodingException -> m a
forall a. EncodingException -> m a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException (Char -> EncodingException
HasNoRepresentation (Int -> Char
chr Int
c))

getT :: BootString -> Int -> Int -> Int
getT :: BootString -> Int -> Int -> Int
getT BootString
bs Int
k Int
bias
	| Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
bias Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (BootString -> Int
tmin BootString
bs) = BootString -> Int
tmin BootString
bs
	| Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bias Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (BootString -> Int
tmax BootString
bs) = BootString -> Int
tmax BootString
bs
	| Bool
otherwise             = Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
bias

adapt :: BootString -> Int -> Int -> Bool -> Int
adapt :: BootString -> Int -> Int -> Bool -> Int
adapt BootString
bs Int
delta Int
numpoints Bool
firsttime = let
	delta1 :: Int
delta1 = if Bool
firsttime
		then Int
delta Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (BootString -> Int
damp BootString
bs)
		else Int
delta Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
	delta2 :: Int
delta2 = Int
delta1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
delta1 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
numpoints)
	(Int
rd,Int
rk) = [(Int, Int)] -> (Int, Int)
forall a. HasCallStack => [a] -> a
head
		([(Int, Int)] -> (Int, Int)) -> [(Int, Int)] -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=((BootString -> Int
base BootString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- BootString -> Int
tmin BootString
bs) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (BootString -> Int
tmax BootString
bs)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)(Int -> Bool) -> ((Int, Int) -> Int) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int, Int) -> Int
forall a b. (a, b) -> a
fst)
		([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> (Int, Int)) -> (Int, Int) -> [(Int, Int)]
forall a. (a -> a) -> a -> [a]
iterate (\(Int
d,Int
k) -> (Int
d Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (BootString -> Int
base BootString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- BootString -> Int
tmin BootString
bs),Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+(BootString -> Int
base BootString
bs))) (Int
delta2,Int
0)
	in Int
rk Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (((BootString -> Int
base BootString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- BootString -> Int
tmin BootString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rd) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (Int
rd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ BootString -> Int
skew BootString
bs))

decodeValue :: ByteSource m => BootString -> Int -> Int -> Int -> Int -> [Int] -> m (Int,[Int])
decodeValue :: forall (m :: * -> *).
ByteSource m =>
BootString -> Int -> Int -> Int -> Int -> [Int] -> m (Int, [Int])
decodeValue BootString
bs Int
bias Int
i Int
k Int
w (Int
x:[Int]
xs)
	| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= BootString -> Int
base BootString
bs                     = DecodingException -> m (Int, [Int])
forall a. DecodingException -> m a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException DecodingException
OutOfRange
	| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (Int
forall a. Bounded a => a
maxBound Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
w       = DecodingException -> m (Int, [Int])
forall a. DecodingException -> m a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException DecodingException
OutOfRange
	| Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
t                           = (Int, [Int]) -> m (Int, [Int])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ni,[Int]
xs)
	| Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
forall a. Bounded a => a
maxBound Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (BootString -> Int
base BootString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t) = DecodingException -> m (Int, [Int])
forall a. DecodingException -> m a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException DecodingException
OutOfRange
        | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
xs                          = DecodingException -> m (Int, [Int])
forall a. DecodingException -> m a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException DecodingException
OutOfRange
	| Bool
otherwise = BootString -> Int -> Int -> Int -> Int -> [Int] -> m (Int, [Int])
forall (m :: * -> *).
ByteSource m =>
BootString -> Int -> Int -> Int -> Int -> [Int] -> m (Int, [Int])
decodeValue BootString
bs Int
bias Int
ni (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+BootString -> Int
base BootString
bs) (Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
*(BootString -> Int
base BootString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t)) [Int]
xs
	where
	ni :: Int
ni = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
w
	t :: Int
t  = BootString -> Int -> Int -> Int
getT BootString
bs Int
k Int
bias

decodeValues :: ByteSource m => BootString -> Int -> [Int] -> m [(Char,Int)]
decodeValues :: forall (m :: * -> *).
ByteSource m =>
BootString -> Int -> [Int] -> m [(Char, Int)]
decodeValues BootString
bs Int
len [Int]
xs = BootString -> Int -> Int -> Int -> Int -> [Int] -> m [(Char, Int)]
forall (m :: * -> *).
ByteSource m =>
BootString -> Int -> Int -> Int -> Int -> [Int] -> m [(Char, Int)]
decodeValues' BootString
bs (BootString -> Int
init_n BootString
bs) Int
0 (BootString -> Int
init_bias BootString
bs) Int
len [Int]
xs

decodeValues' :: ByteSource m => BootString -> Int -> Int -> Int -> Int -> [Int] -> m [(Char,Int)]
decodeValues' :: forall (m :: * -> *).
ByteSource m =>
BootString -> Int -> Int -> Int -> Int -> [Int] -> m [(Char, Int)]
decodeValues' BootString
bs Int
n Int
i Int
bias Int
len [] = [(Char, Int)] -> m [(Char, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
decodeValues' BootString
bs Int
n Int
i Int
bias Int
len [Int]
xs = do
  (Int
ni,[Int]
rst) <- BootString -> Int -> Int -> Int -> Int -> [Int] -> m (Int, [Int])
forall (m :: * -> *).
ByteSource m =>
BootString -> Int -> Int -> Int -> Int -> [Int] -> m (Int, [Int])
decodeValue BootString
bs Int
bias Int
i (BootString -> Int
base BootString
bs) Int
1 [Int]
xs
  let (Int
dn,Int
nni) = Int
ni Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
  let nn :: Int
nn = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
dn
  if Int
dn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
forall a. Bounded a => a
maxBound Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n
     then DecodingException -> m [(Char, Int)]
forall a. DecodingException -> m a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException DecodingException
OutOfRange
     else (do
            [(Char, Int)]
rest <- BootString -> Int -> Int -> Int -> Int -> [Int] -> m [(Char, Int)]
forall (m :: * -> *).
ByteSource m =>
BootString -> Int -> Int -> Int -> Int -> [Int] -> m [(Char, Int)]
decodeValues' BootString
bs Int
nn (Int
nniInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (BootString -> Int -> Int -> Bool -> Int
adapt BootString
bs (Int
niInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
iInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0)) (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Int]
rst
            [(Char, Int)] -> m [(Char, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Char, Int)] -> m [(Char, Int)])
-> [(Char, Int)] -> m [(Char, Int)]
forall a b. (a -> b) -> a -> b
$ (Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int
nn,Int
nni)(Char, Int) -> [(Char, Int)] -> [(Char, Int)]
forall a. a -> [a] -> [a]
:[(Char, Int)]
rest
          )
                                   
insertDeltas :: [(a,Int)] -> [a] -> [a]
insertDeltas :: forall a. [(a, Int)] -> [a] -> [a]
insertDeltas [] [a]
str     = [a]
str
insertDeltas ((a
c,Int
p):[(a, Int)]
xs) [a]
str = let
	([a]
l,[a]
r) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
p [a]
str
	in [(a, Int)] -> [a] -> [a]
forall a. [(a, Int)] -> [a] -> [a]
insertDeltas [(a, Int)]
xs ([a]
l[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a
c][a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
r)

punyDecode :: ByteSource m => [Word8] -> [Word8] -> m String
punyDecode :: forall (m :: * -> *).
ByteSource m =>
[Word8] -> [Word8] -> m String
punyDecode [Word8]
base [Word8]
ext = do
  [Int]
pvals <- (Word8 -> m Int) -> [Word8] -> m [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Word8 -> m Int
forall (m :: * -> *). ByteSource m => Word8 -> m Int
punyValue [Word8]
ext
  [(Char, Int)]
vals <- BootString -> Int -> [Int] -> m [(Char, Int)]
forall (m :: * -> *).
ByteSource m =>
BootString -> Int -> [Int] -> m [(Char, Int)]
decodeValues BootString
punycode ([Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
base) [Int]
pvals
  String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ [(Char, Int)] -> ShowS
forall a. [(a, Int)] -> [a] -> [a]
insertDeltas [(Char, Int)]
vals ((Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr(Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Word8]
base)
  
encodeValue :: BootString -> Int -> Int -> Int -> Int -> [Int]
encodeValue :: BootString -> Int -> Int -> Int -> Int -> [Int]
encodeValue BootString
bs Int
bias Int
delta Int
n Int
c = ((Int, Int, Bool) -> Maybe (Int, (Int, Int, Bool)))
-> (Int, Int, Bool) -> [Int]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (\(Int
q,Int
k,Bool
out) -> let
		t :: Int
t = BootString -> Int -> Int -> Int
getT BootString
bs Int
k Int
bias
		(Int
nq,Int
dc) = (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
t) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` (BootString -> Int
base BootString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t)
		in if Bool
out
			then Maybe (Int, (Int, Int, Bool))
forall a. Maybe a
Nothing
			else (if Int
q Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
t
				then (Int, (Int, Int, Bool)) -> Maybe (Int, (Int, Int, Bool))
forall a. a -> Maybe a
Just (Int
q,(Int
q,Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+BootString -> Int
base BootString
bs,Bool
True))
				else (Int, (Int, Int, Bool)) -> Maybe (Int, (Int, Int, Bool))
forall a. a -> Maybe a
Just (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dc,(Int
nq,Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+BootString -> Int
base BootString
bs,Bool
False)))
		) (Int
delta,BootString -> Int
base BootString
bs,Bool
False)

encodeValues' :: BootString -> Int -> Int -> Int -> Int -> Int -> [Int] -> (Int,Int,Int,[Int])
encodeValues' :: BootString
-> Int
-> Int
-> Int
-> Int
-> Int
-> [Int]
-> (Int, Int, Int, [Int])
encodeValues' BootString
_  Int
_ Int
h Int
bias Int
delta Int
_ []     = (Int
delta,Int
h,Int
bias,[])
encodeValues' BootString
bs Int
b Int
h Int
bias Int
delta Int
n (Int
c:[Int]
cs) = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
c Int
n of
	Ordering
LT -> BootString
-> Int
-> Int
-> Int
-> Int
-> Int
-> [Int]
-> (Int, Int, Int, [Int])
encodeValues' BootString
bs Int
b Int
h Int
bias (Int
deltaInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
n [Int]
cs
	Ordering
GT -> BootString
-> Int
-> Int
-> Int
-> Int
-> Int
-> [Int]
-> (Int, Int, Int, [Int])
encodeValues' BootString
bs Int
b Int
h Int
bias Int
delta Int
n [Int]
cs
	Ordering
EQ -> let
		(Int
ndelta,Int
nh,Int
nbias,[Int]
rest) = BootString
-> Int
-> Int
-> Int
-> Int
-> Int
-> [Int]
-> (Int, Int, Int, [Int])
encodeValues' BootString
bs Int
b (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (BootString -> Int -> Int -> Bool -> Int
adapt BootString
bs Int
delta (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
hInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
b)) Int
0 Int
n [Int]
cs
		xs :: [Int]
xs = BootString -> Int -> Int -> Int -> Int -> [Int]
encodeValue BootString
bs Int
bias Int
delta Int
n Int
c
		in (Int
ndelta,Int
nh,Int
nbias,[Int]
xs[Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++[Int]
rest)

encodeValues :: BootString -> Int -> Int -> Int -> Int -> Int -> Int -> [Int] -> [Int]
encodeValues :: BootString
-> Int -> Int -> Int -> Int -> Int -> Int -> [Int] -> [Int]
encodeValues BootString
bs Int
b Int
l Int
h Int
bias Int
delta Int
n [Int]
cps
	| Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l = []
	| Bool
otherwise = [Int]
outp[Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++BootString
-> Int -> Int -> Int -> Int -> Int -> Int -> [Int] -> [Int]
encodeValues BootString
bs Int
b Int
l Int
nh Int
nbias (Int
ndeltaInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Int]
cps
	where
	m :: Int
m = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
n) [Int]
cps)
	(Int
ndelta,Int
nh,Int
nbias,[Int]
outp) = BootString
-> Int
-> Int
-> Int
-> Int
-> Int
-> [Int]
-> (Int, Int, Int, [Int])
encodeValues' BootString
bs Int
b Int
h Int
bias (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)Int -> Int -> Int
forall a. Num a => a -> a -> a
*(Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Int
m [Int]
cps

breakLast :: (a -> Bool) -> [a] -> Maybe ([a],[a])
breakLast :: forall a. (a -> Bool) -> [a] -> Maybe ([a], [a])
breakLast a -> Bool
p [a]
xs = do
  ([a]
bf,[a]
af,Integer
ind) <- Integer
-> Maybe Integer -> (a -> Bool) -> [a] -> Maybe ([a], [a], Integer)
forall {a} {a}.
(Ord a, Num a) =>
a -> Maybe a -> (a -> Bool) -> [a] -> Maybe ([a], [a], a)
breakLast' Integer
0 Maybe Integer
forall a. Maybe a
Nothing a -> Bool
p [a]
xs
  ([a], [a]) -> Maybe ([a], [a])
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
bf,[a]
af)
    where
      breakLast' :: a -> Maybe a -> (a -> Bool) -> [a] -> Maybe ([a], [a], a)
breakLast' a
n Maybe a
r a -> Bool
p [] = do
        a
v <- Maybe a
r
        ([a], [a], a) -> Maybe ([a], [a], a)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],[],a
v)
      breakLast' a
n Maybe a
r a -> Bool
p (a
x:[a]
xs) = let res :: Maybe ([a], [a], a)
res = if a -> Bool
p a
x
                                          then a -> Maybe a -> (a -> Bool) -> [a] -> Maybe ([a], [a], a)
breakLast' (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a -> Maybe a
forall a. a -> Maybe a
Just a
n) a -> Bool
p [a]
xs
                                          else a -> Maybe a -> (a -> Bool) -> [a] -> Maybe ([a], [a], a)
breakLast' (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1) Maybe a
r a -> Bool
p [a]
xs
                              in do
                                ([a]
bf,[a]
af,a
v) <- Maybe ([a], [a], a)
res
                                ([a], [a], a) -> Maybe ([a], [a], a)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], [a], a) -> Maybe ([a], [a], a))
-> ([a], [a], a) -> Maybe ([a], [a], a)
forall a b. (a -> b) -> a -> b
$ if a
na -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
v then (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
bf,[a]
af,a
v) else ([a]
bf,a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
af,a
v)
                          

instance Encoding BootString where
    encodeChar :: forall (m :: * -> *). ByteSink m => BootString -> Char -> m ()
encodeChar BootString
_ Char
c = String -> m ()
forall a. HasCallStack => String -> a
error String
"Data.Encoding.BootString.encodeChar: Please use 'encode' for encoding BootStrings"
    decodeChar :: forall (m :: * -> *). ByteSource m => BootString -> m Char
decodeChar BootString
_ = String -> m Char
forall a. HasCallStack => String -> a
error String
"Data.Encoding.BootString.decodeChar: Please use 'decode' for decoding BootStrings"
    encode :: forall (m :: * -> *). ByteSink m => BootString -> String -> m ()
encode BootString
bs String
str = let (String
base,String
nbase) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\Char
c -> Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< BootString -> Int
init_n BootString
bs) String
str
	                b :: Int
b = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
base
                    in do
                      [Word8]
res <- (Int -> m Word8) -> [Int] -> m [Word8]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Int -> m Word8
forall (m :: * -> *). ByteSink m => Int -> m Word8
punyChar ([Int] -> m [Word8]) -> [Int] -> m [Word8]
forall a b. (a -> b) -> a -> b
$ BootString
-> Int -> Int -> Int -> Int -> Int -> Int -> [Int] -> [Int]
encodeValues BootString
bs Int
b (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) Int
b (BootString -> Int
init_bias BootString
bs) Int
0 (BootString -> Int
init_n BootString
bs) ((Char -> Int) -> String -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
ord String
str)
                      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
base) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                               (Char -> m ()) -> String -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8(Word8 -> m ()) -> (Char -> Word8) -> Char -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral(Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Int
ord) String
base
                               Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'-')
                      (Word8 -> m ()) -> [Word8] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 [Word8]
res
    decode :: forall (m :: * -> *). ByteSource m => BootString -> m String
decode BootString
bs = do
      [Word8]
wrds <- m Bool -> m Word8 -> m [Word8]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m [a]
untilM m Bool
forall (m :: * -> *). ByteSource m => m Bool
sourceEmpty m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
      let m :: Word8
m = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'-'
      case (Word8 -> Bool) -> [Word8] -> Maybe ([Word8], [Word8])
forall a. (a -> Bool) -> [a] -> Maybe ([a], [a])
breakLast (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==Word8
m) [Word8]
wrds of
        Just ([],[Word8]
_) -> DecodingException -> m String
forall a. DecodingException -> m a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException (Word8 -> DecodingException
IllegalCharacter Word8
m)
	Just ([Word8]
base,Word8
_:[Word8]
nbase) -> case (Word8 -> Bool) -> [Word8] -> Maybe Word8
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Word8
w -> Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> BootString -> Int
init_n BootString
bs) [Word8]
base of
                                Maybe Word8
Nothing -> [Word8] -> [Word8] -> m String
forall (m :: * -> *).
ByteSource m =>
[Word8] -> [Word8] -> m String
punyDecode [Word8]
base [Word8]
nbase
                                Just Word8
ww -> DecodingException -> m String
forall a. DecodingException -> m a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException (Word8 -> DecodingException
IllegalCharacter Word8
ww)
	Maybe ([Word8], [Word8])
Nothing -> [Word8] -> [Word8] -> m String
forall (m :: * -> *).
ByteSource m =>
[Word8] -> [Word8] -> m String
punyDecode [] [Word8]
wrds
    encodeable :: BootString -> Char -> Bool
encodeable BootString
bs Char
c = Bool
True -- XXX: hm, really?