{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Text.Collate.Lang
  ( Lang(..)
  , parseLang
  , renderLang
  , lookupLang
  )
where
import Data.Maybe (listToMaybe, mapMaybe)
import Control.Monad (mzero)
import Data.Ord (Down(..))
import Data.List (sortOn)
import Data.Char (isAlphaNum, isAscii, isDigit, isSpace, isAlpha)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Text.Parsec as P
import Data.Binary (Binary(..))
import Data.String
import Language.Haskell.TH.Syntax (Lift(..))
import Instances.TH.Lift ()
#if MIN_VERSION_base(4,11,0)
#else
import Data.Semigroup (Semigroup(..))
#endif

-- | Represents a BCP 47 language tag (<https://tools.ietf.org/html/bcp47>).
data Lang = Lang{ langLanguage   :: Text
                , langScript     :: Maybe Text
                , langRegion     :: Maybe Text
                , langVariants   :: [Text]
                , langExtensions :: [(Text, [(Text , Text)])]
                , langPrivateUse :: [Text]
                } deriving (Eq, Ord, Show, Lift)

instance IsString Lang where
 fromString =
   fromRight (Lang "und" Nothing Nothing [] [] []) . parseLang . T.pack

instance Binary Lang where
 put (Lang a b c d e f) = put (a,b,c,d,e,f)
 get = do
     (a,b,c,d,e,f) <- get
     return $ Lang a b c d e f

-- | Find best match for a 'Lang' in an association list.
lookupLang :: Lang -> [(Lang, a)] -> Maybe (Lang, a)
lookupLang lang =
    fmap snd
  . listToMaybe
  . sortOn (Down . fst)
  . mapMaybe (\(l,t) ->
       case match l of
         Nothing -> Nothing
         Just x -> Just (x,(l,t)))
 where
  langsMatch l = if langLanguage lang == langLanguage l
                    then Just True
                    else Nothing
  maybeMatch f l = case (f l, f lang) of
                     (Nothing, Nothing) -> Just True
                     (Nothing, Just _)  -> Just False
                     (Just x, mby)      -> case mby of
                                             Just y | x == y -> Just True
                                             _ -> Nothing
  langCollation l = lookup "u" (langExtensions l) >>= lookup "co"
  match l = do
    lm <- langsMatch l
    sm <- maybeMatch langScript l
    rm <- maybeMatch langRegion l
    cm <- maybeMatch langCollation l
    return (lm,sm,rm,cm)

-- | Render a 'Lang' in BCP 47 form.
renderLang :: Lang -> Text
renderLang lang =
    langLanguage lang
     <> maybe "" (T.cons '-') (langScript lang)
     <> maybe "" (T.cons '-') (langRegion lang)
     <> mconcat (map (T.cons '-') (langVariants lang))
     <> mconcat (map renderExtension (langExtensions lang))
     <> renderPrivateUse (langPrivateUse lang)
 where
  renderExtension (c, ks) = "-" <> c <> mconcat (map renderKeyword ks)
  renderKeyword (k, v) = "-" <> k <> if T.null v
                                        then ""
                                        else "-" <> v
  renderPrivateUse [] = ""
  renderPrivateUse ts = "-x" <> mconcat (map (T.cons '-') ts)

-- | Parse a BCP 47 language tag as a 'Lang'.
parseLang :: Text -> Either String Lang
parseLang lang =
  case P.parse pLangTag "lang" (T.split (\c -> c == '-' || c == '_')
                                 $ T.takeWhile (not . isSpace) lang) of
       Right r -> Right r
       Left e  -> Left $ show e
  where
    -- langtag       = language
    --                ["-" script]
    --                ["-" region]
    --                 *("-" variant)
    --                 *("-" extension)
    pLangTag = do
      language <- pLanguage P.<?> "language"
      script <- P.option Nothing (Just <$> pScript P.<?> "script")
      region <- P.option Nothing (Just <$> pRegion P.<?> "region")
      variants <- P.many pVariant P.<?> "variant"
      extensions <- P.many pExtension P.<?> "extension"
      privateUse <- P.option [] (pPrivateUse P.<?> "private use")
      -- P.eof  -- like CSL, we allow garbage afterwards
      return Lang{   langLanguage = language
                   , langScript = script
                   , langRegion = region
                   , langVariants = variants
                   , langExtensions = extensions
                   , langPrivateUse = privateUse }

    -- language      = 2*3ALPHA            ; shortest ISO 639 code
    --                 ["-" extlang]       ; sometimes followed by
    --                                     ; extended language subtags
    --               / 4ALPHA              ; or reserved for future use
    --               / 5*8ALPHA            ; or registered language subtag
    pLanguage = (do
      baselang <- T.toLower <$> alphasBetween 2 3
      extlang <- P.option Nothing $ Just <$> pExtlang
      case extlang of
        Nothing  -> pure baselang
        Just ext -> pure $ baselang <> "-" <> ext)
      P.<|> T.toLower <$> alphasBetween 4 8

    -- extlang       = 3ALPHA              ; selected ISO 639 codes
    --                 *2("-" 3ALPHA)      ; permanently reserved
    pExtlang = T.intercalate "-" <$> countBetween 1 3
                 (T.toLower <$> alphas 3)

    -- script        = 4ALPHA              ; ISO 15924 code
    pScript = T.toTitle <$> alphas 4

    -- region        = 2ALPHA              ; ISO 3166-1 code
    --               / 3DIGIT              ; UN M.49 code
    pRegion = T.toUpper <$> alphas 2 P.<|> digits 3

    -- variant       = 5*8alphanum         ; registered variants
    --              / (DIGIT 3alphanum)
    pVariant = T.toLower <$>
      (alphanumsBetween 5 8
       P.<|> tok (\t -> T.all isAsciiAlphaNum t && T.length t == 4 &&
                                    isDigit (T.head t)))

    -- extension     = singleton 1*("-" (2*8alphanum))
    -- RFC6087:
    -- An 'attribute' is a subtag with a length of three to eight
    -- characters following the singleton and preceding any 'keyword'
    -- sequences.  No attributes were defined at the time of this
    -- document's publication.

    -- A 'keyword' is a sequence of subtags consisting of a 'key' subtag,
    -- followed by zero or more 'type' subtags (so a 'key' might appear
    -- alone and not be accompanied by a 'type' subtag).  A 'key' MUST
    -- NOT appear more than once in a language tag's extension string.
    -- The order of the 'type' subtags within a 'keyword' is sometimes
    -- significant to their interpretation.

    -- A.  A 'key' is a subtag with a length of exactly two characters.
    --     Each 'key' is followed by zero or more 'type' subtags.

    -- B.  A 'type' is a subtag with a length of three to eight
    --     characters following a 'key'.  'Type' subtags are specific to
    --     a particular 'key' and the order of the 'type' subtags MAY be
    --     significant to the interpretation of the 'keyword'.
    pExtension = do
      c <- T.toLower <$> tok (\t -> T.length t == 1 && T.all isAsciiAlphaNum t)
      attrs <- P.many
             (T.toLower <$>
               tok (\t -> T.all isAsciiAlphaNum t && lengthBetween 3 8 t))
      keywords <- P.many pKeyword
      return (c, map (, "") attrs ++ keywords)

    pKeyword = do
      key <- alphas 2
      types <- P.many (alphanumsBetween 3 8)
      return (key, T.intercalate "-" types)

    -- privateuse    = "x" 1*("-" (1*8alphanum))
    pPrivateUse = do
      _ <- tok (\t -> T.toLower t == "x")
      P.many1 (alphanumsBetween 1 8)

    tok :: (Text -> Bool) -> P.Parsec [Text] () Text
    tok f = P.tokenPrim T.unpack (\pos t _ ->
                                   P.incSourceColumn pos (T.length t))
                      (\t -> if f t then Just t else Nothing)

    countBetween (low :: Int) (hi :: Int) p = P.try $ countBetween' low hi p 1
    countBetween' low hi p (n :: Int) = (do
     res <- p
     if n >= hi
        then return [res]
        else (res:) <$> countBetween' low hi p (n + 1))
      P.<|> (if n > low then return [] else mzero)

    isAsciiAlpha c = isAscii c && isAlpha c
    alphas len = tok (\t -> T.all isAsciiAlpha t && T.length t == len)
    digits len = tok (\t -> T.all isDigit t && T.length t == len)
    alphasBetween minLen maxLen =
      tok (\t -> T.all isAsciiAlpha t && lengthBetween minLen maxLen t)
    alphanumsBetween minLen maxLen =
      tok (\t -> T.all isAsciiAlphaNum t && lengthBetween minLen maxLen t)
    lengthBetween lo hi t = let len = T.length t in len >= lo && len <= hi
    isAsciiAlphaNum c = isAscii c && isAlphaNum c


-- We define fromRight here instead of importing it,
-- because it doesn't exist in some base versions we support.
fromRight :: b -> Either a b -> b
fromRight fallback (Left _)  = fallback
fromRight _        (Right x) = x