{-# LANGUAGE OverloadedStrings #-}
-- | This module implements the two algorithms from RFC 3490. (<http://tools.ietf.org/html/rfc3490>)
module Text.IDNA (acePrefix, toASCII, toUnicode)
where

import Text.StringPrep
import Text.StringPrep.Profiles
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Text.Punycode as Puny
import Data.Text.Encoding as E

-- | The ASCII Compatible Encoding prefix (currently \'@xn--@\').
acePrefix :: Text
acePrefix :: Text
acePrefix = Text
"xn--"

-- | Implements the ToASCII algorithm.
toASCII :: Bool -- ^ Whether to allow unassigned code points (in RFC: AllowUnassigned).
	-> Bool -- ^ Whether to disallow certain ASCII characters (in RFC: UseSTD3ASCIIRules). 
	-> Text -- ^ The text to transform.
	-> Maybe Text
toASCII :: Bool -> Bool -> Text -> Maybe Text
toASCII Bool
allowUnassigned Bool
useSTD3ASCIIRules Text
t = do
		Text
step2 <- if (Char -> Bool) -> Text -> Bool
Text.any (Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>Char
'\x7f') Text
t
			then StringPrepProfile -> Text -> Maybe Text
runStringPrep (Bool -> StringPrepProfile
namePrepProfile Bool
allowUnassigned) Text
t
			else Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t

		Text
step3 <- if (Bool
useSTD3ASCIIRules Bool -> Bool -> Bool
&& ((Char -> Bool) -> Text -> Bool
Text.any Char -> Bool
isLDHascii Text
step2 Bool -> Bool -> Bool
||	Text -> Char
Text.head Text
step2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Text -> Char
Text.last Text
step2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'))
			then Maybe Text
forall a. Maybe a
Nothing
			else Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
step2

		Text
step7 <- if ((Char -> Bool) -> Text -> Bool
Text.any (Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>Char
'\x7f') Text
step2)
				then if Text
acePrefix Text -> Text -> Bool
`Text.isPrefixOf` Text
step3
					then Maybe Text
forall a. Maybe a
Nothing
					else case ByteString -> Either Any ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ByteString
Puny.encode Text
step3) of -- TODO: this can fail?
						Left Any
_ -> Maybe Text
forall a. Maybe a
Nothing
						Right ByteString
t' -> Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
acePrefix Text -> Text -> Text
`Text.append` ByteString -> Text
E.decodeUtf8 ByteString
t'
				else Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
step3
		
		if Text -> Int
Text.length Text
step7 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
63
			then Text -> Maybe Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
step7
			else Maybe Text
forall a. Maybe a
Nothing

isLDHascii :: Char -> Bool
isLDHascii :: Char -> Bool
isLDHascii Char
c =
	Char
'\x0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x2c' Bool -> Bool -> Bool
||
	Char
'\x2e' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x2f' Bool -> Bool -> Bool
||
	Char
'\x3a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x40' Bool -> Bool -> Bool
||
	Char
'\x5b' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x60' Bool -> Bool -> Bool
||
	Char
'\x7b' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\x7f' 

toUnicode :: Bool -- ^ Whether to allow unassigned code points (in RFC: AllowUnassigned).
	-> Bool -- ^ Whether to disallow certain ASCII characters (in RFC: UseSTD3ASCIIRules). 
	-> Text -- ^ The text to transform.
	-> Text
toUnicode :: Bool -> Bool -> Text -> Text
toUnicode Bool
allowUnassigned Bool
useSTD3ASCIIRules Text
t = Either Text Text -> Text
forall a. Either a a -> a
mergeEither (Either Text Text -> Text) -> Either Text Text -> Text
forall a b. (a -> b) -> a -> b
$ do
	Text
step2 <- if (Char -> Bool) -> Text -> Bool
Text.any (Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>Char
'\x7f') Text
t
		then case StringPrepProfile -> Text -> Maybe Text
runStringPrep (Bool -> StringPrepProfile
namePrepProfile Bool
allowUnassigned) Text
t of
			Maybe Text
Nothing -> Text -> Either Text Text
forall a b. a -> Either a b
Left Text
t
			Just Text
t' -> Text -> Either Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t'
		else Text -> Either Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t

	Text
step3 <- if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
acePrefix Text -> Text -> Bool
`Text.isPrefixOf` Text
step2
		then Text -> Either Text Text
forall a b. a -> Either a b
Left Text
step2
		else Text -> Either Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
step2
	
	let step4 :: Text
step4 = Int -> Text -> Text
Text.drop (Text -> Int
Text.length Text
acePrefix) Text
step3
	Text
step5 <- case ByteString -> Either PunycodeDecodeException Text
Puny.decode (ByteString -> Either PunycodeDecodeException Text)
-> ByteString -> Either PunycodeDecodeException Text
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
E.encodeUtf8 Text
step4 of
		Left PunycodeDecodeException
_ -> Text -> Either Text Text
forall a b. a -> Either a b
Left Text
step3
		Right Text
s -> Text -> Either Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
s

	case Bool -> Bool -> Text -> Maybe Text
toASCII Bool
allowUnassigned Bool
useSTD3ASCIIRules Text
step5 of
		Maybe Text
Nothing -> Text -> Either Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
step3
		Just Text
t' -> if Text
t' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
step3
			then Text -> Either Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
step5
			else Text -> Either Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
step3

mergeEither :: Either a a -> a
mergeEither :: forall a. Either a a -> a
mergeEither (Left a
x) = a
x
mergeEither (Right a
y) = a
y

tests :: [Text]
tests :: [Text]
tests = [Text
"Bücher",Text
"tūdaliņ"]