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

module Data.BCP47.Internal.Extension
  ( Extension (Extension)
  , extensionFromText
  , extensionToText
  , extensionP
  )
where

import Control.Monad (void, when)
import Data.BCP47.Internal.Arbitrary
  ( Arbitrary
  , alphaChar
  , alphaNumString
  , arbitrary
  , choose
  , suchThat
  )
import Data.BCP47.Internal.CIText (CIText)
import qualified Data.BCP47.Internal.CIText as CI
import Data.BCP47.Internal.Parser (asciiLetterDigit, complete)
import Data.Bifunctor (first)
import Data.Text (Text, pack)
import Data.Void (Void)
import Text.Megaparsec (Parsec, count', parse)
import Text.Megaparsec.Char (char)
import Text.Megaparsec.Error (errorBundlePretty)

-- | Extension subtags
--
-- Extensions provide a mechanism for extending language tags for use in
-- various applications.  They are intended to identify information that
-- is commonly used in association with languages or language tags but
-- that is not part of language identification.
newtype Extension = Extension {Extension -> CIText
unExtension :: CIText}
  deriving stock (Int -> Extension -> ShowS
[Extension] -> ShowS
Extension -> String
(Int -> Extension -> ShowS)
-> (Extension -> String)
-> ([Extension] -> ShowS)
-> Show Extension
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Extension -> ShowS
showsPrec :: Int -> Extension -> ShowS
$cshow :: Extension -> String
show :: Extension -> String
$cshowList :: [Extension] -> ShowS
showList :: [Extension] -> ShowS
Show, Extension -> Extension -> Bool
(Extension -> Extension -> Bool)
-> (Extension -> Extension -> Bool) -> Eq Extension
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Extension -> Extension -> Bool
== :: Extension -> Extension -> Bool
$c/= :: Extension -> Extension -> Bool
/= :: Extension -> Extension -> Bool
Eq, Eq Extension
Eq Extension =>
(Extension -> Extension -> Ordering)
-> (Extension -> Extension -> Bool)
-> (Extension -> Extension -> Bool)
-> (Extension -> Extension -> Bool)
-> (Extension -> Extension -> Bool)
-> (Extension -> Extension -> Extension)
-> (Extension -> Extension -> Extension)
-> Ord Extension
Extension -> Extension -> Bool
Extension -> Extension -> Ordering
Extension -> Extension -> Extension
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
$ccompare :: Extension -> Extension -> Ordering
compare :: Extension -> Extension -> Ordering
$c< :: Extension -> Extension -> Bool
< :: Extension -> Extension -> Bool
$c<= :: Extension -> Extension -> Bool
<= :: Extension -> Extension -> Bool
$c> :: Extension -> Extension -> Bool
> :: Extension -> Extension -> Bool
$c>= :: Extension -> Extension -> Bool
>= :: Extension -> Extension -> Bool
$cmax :: Extension -> Extension -> Extension
max :: Extension -> Extension -> Extension
$cmin :: Extension -> Extension -> Extension
min :: Extension -> Extension -> Extension
Ord)

extensionToText :: Extension -> Text
extensionToText :: Extension -> Text
extensionToText = CIText -> Text
CI.original (CIText -> Text) -> (Extension -> CIText) -> Extension -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> CIText
unExtension

instance Arbitrary Extension where
  arbitrary :: Gen Extension
arbitrary = do
    Char
prefix <- Gen Char
alphaChar Gen Char -> (Char -> Bool) -> Gen Char
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'x', Char
'X'])
    Int
len <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
2, Int
8)
    String
chars <- Int -> Gen String
alphaNumString Int
len
    Extension -> Gen Extension
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Extension -> Gen Extension)
-> (String -> Extension) -> String -> Gen Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CIText -> Extension
Extension (CIText -> Extension) -> (String -> CIText) -> String -> Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CIText
CI.pack (String -> Gen Extension) -> String -> Gen Extension
forall a b. (a -> b) -> a -> b
$ Char
prefix Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: String
chars

-- | Parse an 'Extension' subtag from 'Text'
extensionFromText :: Text -> Either Text Extension
extensionFromText :: Text -> Either Text Extension
extensionFromText =
  (ParseErrorBundle Text Void -> Text)
-> Either (ParseErrorBundle Text Void) Extension
-> Either Text Extension
forall a b c. (a -> b) -> Either a c -> Either b c
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) Extension
 -> Either Text Extension)
-> (Text -> Either (ParseErrorBundle Text Void) Extension)
-> Text
-> Either Text Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text Extension
-> String -> Text -> Either (ParseErrorBundle Text Void) Extension
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text Extension
extensionP String
"extensionFromText"

-- | BCP-47 extension parser
--
-- @@
-- extension     = singleton 1*("-" (2*8alphanum))
--                                     ; Single alphanumerics
--                                     ; "x" reserved for private use
--
-- singleton     = DIGIT               ; 0 - 9
--               / %x41-57             ; A - W
--               / %x59-5A             ; Y - Z
--               / %x61-77             ; a - w
--               / %x79-7A             ; y - z
-- @@
extensionP :: Parsec Void Text Extension
extensionP :: Parsec Void Text Extension
extensionP = Parsec Void Text Extension -> Parsec Void Text Extension
forall a. Parsec Void Text a -> Parsec Void Text a
complete (Parsec Void Text Extension -> Parsec Void Text Extension)
-> Parsec Void Text Extension -> Parsec Void Text Extension
forall a b. (a -> b) -> a -> b
$ do
  Char
ext <- Parsec Void Text Char
asciiLetterDigit
  Bool
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
ext Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'x', Char
'X']) (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT Void Text Identity ()
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"private use suffix found"
  Parsec Void Text Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parsec Void Text Char -> ParsecT Void Text Identity ())
-> Parsec Void Text 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
rest <- Int
-> Int
-> Parsec Void Text Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
2 Int
8 Parsec Void Text Char
asciiLetterDigit
  Extension -> Parsec Void Text Extension
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Extension -> Parsec Void Text Extension)
-> (String -> Extension) -> String -> Parsec Void Text Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CIText -> Extension
Extension (CIText -> Extension) -> (String -> CIText) -> String -> Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CIText
CI.pack (String -> Parsec Void Text Extension)
-> String -> Parsec Void Text Extension
forall a b. (a -> b) -> a -> b
$ Char
ext Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: String
rest