{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.BCP47.Internal.LanguageExtension
  ( LanguageExtension(LanguageExtension)
  , languageExtensionFromText
  , languageExtensionToText
  , languageExtensionP
  )
where

import Control.Monad (replicateM, void)
import Data.BCP47.Internal.Arbitrary (Arbitrary, alphaString, arbitrary)
import Data.BCP47.Internal.Parser (complete)
import Data.Bifunctor (first)
import Data.List (intercalate)
import Data.Text (Text, pack)
import Data.Void (Void)
import Text.Megaparsec (Parsec, count, parse)
import Text.Megaparsec.Char (char, letterChar)
import Text.Megaparsec.Error (errorBundlePretty)

-- | Extended language subtags
--
-- These are used to identify certain specially selected languages that, for
-- various historical and compatibility reasons, are closely identified with or
-- tagged using an existing primary language subtag.
--
newtype LanguageExtension = LanguageExtension { LanguageExtension -> Text
languageExtensionToText :: Text }
  deriving stock (Int -> LanguageExtension -> ShowS
[LanguageExtension] -> ShowS
LanguageExtension -> String
(Int -> LanguageExtension -> ShowS)
-> (LanguageExtension -> String)
-> ([LanguageExtension] -> ShowS)
-> Show LanguageExtension
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LanguageExtension] -> ShowS
$cshowList :: [LanguageExtension] -> ShowS
show :: LanguageExtension -> String
$cshow :: LanguageExtension -> String
showsPrec :: Int -> LanguageExtension -> ShowS
$cshowsPrec :: Int -> LanguageExtension -> ShowS
Show, LanguageExtension -> LanguageExtension -> Bool
(LanguageExtension -> LanguageExtension -> Bool)
-> (LanguageExtension -> LanguageExtension -> Bool)
-> Eq LanguageExtension
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LanguageExtension -> LanguageExtension -> Bool
$c/= :: LanguageExtension -> LanguageExtension -> Bool
== :: LanguageExtension -> LanguageExtension -> Bool
$c== :: LanguageExtension -> LanguageExtension -> Bool
Eq, Eq LanguageExtension
Eq LanguageExtension
-> (LanguageExtension -> LanguageExtension -> Ordering)
-> (LanguageExtension -> LanguageExtension -> Bool)
-> (LanguageExtension -> LanguageExtension -> Bool)
-> (LanguageExtension -> LanguageExtension -> Bool)
-> (LanguageExtension -> LanguageExtension -> Bool)
-> (LanguageExtension -> LanguageExtension -> LanguageExtension)
-> (LanguageExtension -> LanguageExtension -> LanguageExtension)
-> Ord LanguageExtension
LanguageExtension -> LanguageExtension -> Bool
LanguageExtension -> LanguageExtension -> Ordering
LanguageExtension -> LanguageExtension -> LanguageExtension
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LanguageExtension -> LanguageExtension -> LanguageExtension
$cmin :: LanguageExtension -> LanguageExtension -> LanguageExtension
max :: LanguageExtension -> LanguageExtension -> LanguageExtension
$cmax :: LanguageExtension -> LanguageExtension -> LanguageExtension
>= :: LanguageExtension -> LanguageExtension -> Bool
$c>= :: LanguageExtension -> LanguageExtension -> Bool
> :: LanguageExtension -> LanguageExtension -> Bool
$c> :: LanguageExtension -> LanguageExtension -> Bool
<= :: LanguageExtension -> LanguageExtension -> Bool
$c<= :: LanguageExtension -> LanguageExtension -> Bool
< :: LanguageExtension -> LanguageExtension -> Bool
$c< :: LanguageExtension -> LanguageExtension -> Bool
compare :: LanguageExtension -> LanguageExtension -> Ordering
$ccompare :: LanguageExtension -> LanguageExtension -> Ordering
$cp1Ord :: Eq LanguageExtension
Ord)

instance Arbitrary LanguageExtension where
  arbitrary :: Gen LanguageExtension
arbitrary = do
    [String]
components <- Int -> Gen String -> Gen [String]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 (Gen String -> Gen [String]) -> Gen String -> Gen [String]
forall a b. (a -> b) -> a -> b
$ Int -> Gen String
alphaString Int
3
    LanguageExtension -> Gen LanguageExtension
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LanguageExtension -> Gen LanguageExtension)
-> (Text -> LanguageExtension) -> Text -> Gen LanguageExtension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LanguageExtension
LanguageExtension (Text -> Gen LanguageExtension) -> Text -> Gen LanguageExtension
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String]
components

-- | Parse a 'LanguageExtension' subtag from 'Text'
languageExtensionFromText :: Text -> Either Text LanguageExtension
languageExtensionFromText :: Text -> Either Text LanguageExtension
languageExtensionFromText = (ParseErrorBundle Text Void -> Text)
-> Either (ParseErrorBundle Text Void) LanguageExtension
-> Either Text LanguageExtension
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
pack (String -> Text)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty)
  (Either (ParseErrorBundle Text Void) LanguageExtension
 -> Either Text LanguageExtension)
-> (Text -> Either (ParseErrorBundle Text Void) LanguageExtension)
-> Text
-> Either Text LanguageExtension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text LanguageExtension
-> String
-> Text
-> Either (ParseErrorBundle Text Void) LanguageExtension
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text LanguageExtension
languageExtensionP String
"languageExtensionFromText"

-- | BCP-47 language extension parser
--
-- This only implements the ISO 639 portion of the ISO.
--
-- @@
--  extlang       = 3ALPHA              ; selected ISO 639 codes
--                 *2("-" 3ALPHA)      ; permanently reserved
-- @@
--
languageExtensionP :: Parsec Void Text LanguageExtension
languageExtensionP :: Parsec Void Text LanguageExtension
languageExtensionP = Parsec Void Text LanguageExtension
-> Parsec Void Text LanguageExtension
forall a. Parsec Void Text a -> Parsec Void Text a
complete (Parsec Void Text LanguageExtension
 -> Parsec Void Text LanguageExtension)
-> Parsec Void Text LanguageExtension
-> Parsec Void Text LanguageExtension
forall a b. (a -> b) -> a -> b
$ do
  String
iso639 <- Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
3 ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar
  ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-'
  String
c1 <- Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
3 ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar
  ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-'
  String
c2 <- Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
3 ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar
  let ext :: Text
ext = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat [String
iso639, String
"-", String
c1, String
"-", String
c2]
  LanguageExtension -> Parsec Void Text LanguageExtension
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LanguageExtension -> Parsec Void Text LanguageExtension)
-> LanguageExtension -> Parsec Void Text LanguageExtension
forall a b. (a -> b) -> a -> b
$ Text -> LanguageExtension
LanguageExtension Text
ext