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

module Data.BCP47.Internal.Script
  ( Script (Script)
  , scriptFromText
  , scriptToText
  , scriptP
  )
where

import Data.BCP47.Internal.Arbitrary (Arbitrary, alphaString, arbitrary)
import Data.BCP47.Internal.CIText (CIText)
import qualified Data.BCP47.Internal.CIText as CI
import Data.BCP47.Internal.Parser (asciiLetter, complete)
import Data.Bifunctor (first)
import Data.Text (Text, pack)
import Data.Void (Void)
import Text.Megaparsec (Parsec, count, parse)
import Text.Megaparsec.Error (errorBundlePretty)

-- | Script subtags
--
-- Script subtags are used to indicate the script or writing system
-- variations that distinguish the written forms of a language or its
-- dialects.
newtype Script = Script {Script -> CIText
unScript :: CIText}
  deriving stock (Int -> Script -> ShowS
[Script] -> ShowS
Script -> String
(Int -> Script -> ShowS)
-> (Script -> String) -> ([Script] -> ShowS) -> Show Script
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Script -> ShowS
showsPrec :: Int -> Script -> ShowS
$cshow :: Script -> String
show :: Script -> String
$cshowList :: [Script] -> ShowS
showList :: [Script] -> ShowS
Show, Script -> Script -> Bool
(Script -> Script -> Bool)
-> (Script -> Script -> Bool) -> Eq Script
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Script -> Script -> Bool
== :: Script -> Script -> Bool
$c/= :: Script -> Script -> Bool
/= :: Script -> Script -> Bool
Eq, Eq Script
Eq Script =>
(Script -> Script -> Ordering)
-> (Script -> Script -> Bool)
-> (Script -> Script -> Bool)
-> (Script -> Script -> Bool)
-> (Script -> Script -> Bool)
-> (Script -> Script -> Script)
-> (Script -> Script -> Script)
-> Ord Script
Script -> Script -> Bool
Script -> Script -> Ordering
Script -> Script -> Script
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 :: Script -> Script -> Ordering
compare :: Script -> Script -> Ordering
$c< :: Script -> Script -> Bool
< :: Script -> Script -> Bool
$c<= :: Script -> Script -> Bool
<= :: Script -> Script -> Bool
$c> :: Script -> Script -> Bool
> :: Script -> Script -> Bool
$c>= :: Script -> Script -> Bool
>= :: Script -> Script -> Bool
$cmax :: Script -> Script -> Script
max :: Script -> Script -> Script
$cmin :: Script -> Script -> Script
min :: Script -> Script -> Script
Ord)

scriptToText :: Script -> Text
scriptToText :: Script -> Text
scriptToText = CIText -> Text
CI.original (CIText -> Text) -> (Script -> CIText) -> Script -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script -> CIText
unScript

instance Arbitrary Script where
  arbitrary :: Gen Script
arbitrary = CIText -> Script
Script (CIText -> Script) -> (String -> CIText) -> String -> Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CIText
CI.pack (String -> Script) -> Gen String -> Gen Script
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen String
alphaString Int
4

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

-- | BCP-47 script parser
--
-- @@
--  script        = 4ALPHA              ; ISO 15924 code
-- @@
scriptP :: Parsec Void Text Script
scriptP :: Parsec Void Text Script
scriptP = Parsec Void Text Script -> Parsec Void Text Script
forall a. Parsec Void Text a -> Parsec Void Text a
complete (Parsec Void Text Script -> Parsec Void Text Script)
-> Parsec Void Text Script -> Parsec Void Text Script
forall a b. (a -> b) -> a -> b
$ CIText -> Script
Script (CIText -> Script) -> (String -> CIText) -> String -> Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CIText
CI.pack (String -> Script)
-> ParsecT Void Text Identity String -> Parsec Void Text Script
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
4 ParsecT Void Text Identity Char
asciiLetter