{-# 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.Parser (complete)
import Data.Bifunctor (first)
import Data.Text (Text, pack)
import Data.Void (Void)
import Text.Megaparsec (Parsec, count', parse)
import Text.Megaparsec.Char (alphaNumChar, 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 -> Text
extensionToText :: Text }
  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
showList :: [Extension] -> ShowS
$cshowList :: [Extension] -> ShowS
show :: Extension -> String
$cshow :: Extension -> String
showsPrec :: Int -> Extension -> ShowS
$cshowsPrec :: Int -> Extension -> ShowS
Show, Extension -> Extension -> Bool
(Extension -> Extension -> Bool)
-> (Extension -> Extension -> Bool) -> Eq Extension
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Extension -> Extension -> Bool
$c/= :: Extension -> Extension -> Bool
== :: Extension -> Extension -> Bool
$c== :: 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
min :: Extension -> Extension -> Extension
$cmin :: Extension -> Extension -> Extension
max :: Extension -> Extension -> Extension
$cmax :: Extension -> Extension -> Extension
>= :: Extension -> Extension -> Bool
$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
compare :: Extension -> Extension -> Ordering
$ccompare :: Extension -> Extension -> Ordering
$cp1Ord :: Eq Extension
Ord)

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 (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
. Text -> Extension
Extension (Text -> Extension) -> (String -> Text) -> String -> Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
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 (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 <- ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  Bool
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
ext Char -> String -> 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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"private use suffix found"
  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
rest <- Int
-> Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => Int -> Int -> m a -> m [a]
count' Int
2 Int
8 ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  Extension -> Parsec Void Text Extension
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
. Text -> Extension
Extension (Text -> Extension) -> (String -> Text) -> String -> Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
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