{-# LANGUAGE OverloadedStrings #-}
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
acePrefix :: Text
acePrefix :: Text
acePrefix = Text
"xn--"
toASCII :: Bool
-> Bool
-> Text
-> 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 a. a -> Maybe a
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
|| HasCallStack => Text -> Char
Text -> Char
Text.head Text
step2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| HasCallStack => Text -> Char
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 a. a -> Maybe a
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 a. a -> Either Any a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ByteString
Puny.encode Text
step3) of
Left Any
_ -> Maybe Text
forall a. Maybe a
Nothing
Right ByteString
t' -> Text -> Maybe Text
forall a. a -> Maybe a
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 a. a -> Maybe a
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 a. a -> Maybe a
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
-> Bool
-> Text
-> 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 a. a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t'
else Text -> Either Text Text
forall a. a -> Either Text a
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 a. a -> Either Text a
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 a. a -> Either Text a
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 a. a -> Either Text a
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 a. a -> Either Text a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
step5
else Text -> Either Text Text
forall a. a -> Either Text a
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ņ"]