content: {-# LANGUAGE OverloadedStrings #-}
  module Text.Seonbi.Html.Lang
      ( LangHtmlEntity (..)
      , LanguageTag
      , annotateWithLang
      , extractLang
      , isKorean
      , isNeverKorean
      ) where
  
  import Control.Applicative
  import Data.Char (isSpace)
  import Data.Maybe
  
  import Data.Attoparsec.Text
  import Data.Text
  
  import Text.Seonbi.Html.Entity
  import Text.Seonbi.Html.Tag (HtmlTag)
  
  -- | Represents a language tag.  Although it is defined as an alias for 'Text',
  -- it can be structured in the future.  Do not use its contents directly.
  type LanguageTag = Text
  
  -- | Extracts the language tag from the given raw HTML attributes if it has
  -- @lang@ attribute.
  --
  -- >>> extractLang ""
  -- Nothing
  -- >>> extractLang "lang=en"
  -- Just "en"
  -- >>> extractLang "lang=\"ko-KR\""
  -- Just "ko-kr"
  -- >>> extractLang " lang='ko-Hang'"
  -- Just "ko-hang"
  extractLang
      :: HtmlRawAttrs
      -- ^ A raw HTML attributes to extract the language tag from.
      -> Maybe LanguageTag
      -- ^ A language tag extracted from the given raw HTML attributes.
      -- If the given raw HTML attributes does not have @lang@ attribute or
      -- its value is invalid, 'Nothing' is returned.
  extractLang attrs =
      case parseOnly parser' attrs of
          Right (Just lang') ->
              let lt = toLower . strip . normalizeEntities $ lang'
              in if Data.Text.null lt then Nothing else Just lt
          _ -> Nothing
    where
      parser' :: Parser (Maybe Text)
      parser' = do
          skipSpace
          attrs' <- langAttr `sepBy` space
          skipSpace
          return $ listToMaybe $ catMaybes attrs'
      langAttr :: Parser (Maybe Text)
      langAttr = do
          (isLang, cont) <- attrIsLang
          value <- if cont then attrValue else return ""
          return (if isLang then Just value else Nothing)
      attrIsLang :: Parser (Bool, Bool)
      attrIsLang = choice
          [ asciiCI "lang=" >> return (True, True)
          , do { _ <- takeWhile1 (/= '=')
               ; eq <- optional (char '=')
               ; return (False, isJust eq)
               }
          ]
      attrValue :: Parser Text
      attrValue = choice
          [ do { skip (== '"'); v <- takeTill (== '"'); skip (== '"'); return v }
          , do { skip (== '\'')
               ; v <- takeTill (== '\'')
               ; skip (== '\''); return v
               }
          , takeWhile1 (not . isSpace)
          ]
      normalizeEntities :: Text -> Text
      normalizeEntities
          = Data.Text.replace "&hyphen;" "-"
          . Data.Text.replace "&dash;" "-"
          . Data.Text.replace "&#8208;" "-"
          . Data.Text.replace "&#x2010;" "-"
          . Data.Text.replace "&#X2010;" "-"
  
  -- | Annotates 'HtmlEntity' with the 'lang' tag extracted from it or its
  -- ancestors.
  data LangHtmlEntity = LangHtmlEntity
      { -- | The @lang@ tag extracted from the HTML 'entity' or its ancestors.
        lang :: Maybe LanguageTag
        -- | The annotated HTML 'entity'.
      , entity :: HtmlEntity
      } deriving (Show, Eq)
  
  -- | Annotates the given HTML entities with the language tag extracted from
  -- their @lang@ attributes.  If a parent entity has @lang@ attribute, its
  -- all descendants are annotated with the same language tag.
  annotateWithLang :: [HtmlEntity] -> [LangHtmlEntity]
  annotateWithLang =
      annotate []
    where
      annotate :: [(HtmlTag, Maybe LanguageTag)]
               -> [HtmlEntity]
               -> [LangHtmlEntity]
      annotate _ [] = []
      annotate stack (x@HtmlStartTag { tag = tag', rawAttributes = attrs } : xs) =
          LangHtmlEntity thisLang x : annotate nextStack xs
        where
          parentLang :: Maybe LanguageTag
          parentLang = case stack of
              (_, l):_ -> l
              _ -> Nothing
          thisLang :: Maybe LanguageTag
          thisLang = extractLang attrs <|> parentLang
          nextStack :: [(HtmlTag, Maybe LanguageTag)]
          nextStack = (tag', thisLang) : stack
      annotate stack (x@HtmlEndTag { tag = tag' } : xs) =
          LangHtmlEntity thisLang x : annotate nextStack xs
        where
          (nextStack, thisLang) = case stack of
              [] -> ([], Nothing)
              s@((t, lang'):ys) ->
                  (if t == tag' then ys else s, lang')
      annotate stack (x : xs) =
          LangHtmlEntity parentLang x : annotate stack xs
        where
          parentLang :: Maybe LanguageTag
          parentLang = case stack of
              (_, l):_ -> l
              _ -> Nothing
  
  -- | Determines whether the given language tag refers to any kind of Korean.
  --
  -- >>> isKorean "ko"
  -- True
  -- >>> isKorean "ko-KR"
  -- True
  -- >>> isKorean "kor-Hang"
  -- True
  -- >>> isKorean "en"
  -- False
  -- >>> isKorean "en-KR"
  -- False
  isKorean :: LanguageTag -> Bool
  isKorean lang' =
      l == "ko" || l == "kor" ||
      "ko-" `isPrefixOf` l ||
      "kor-" `isPrefixOf` l
    where
      l :: Text
      l = toLower lang'
  
  -- | Determines whether the given language tag undoubtedly does not refer
  -- to any kind of Korean.
  --
  -- >>> isNeverKorean $ Just "ko"
  -- False
  -- >>> isNeverKorean $ Just "ko-KR"
  -- False
  -- >>> isNeverKorean Nothing
  -- False
  -- >>> isNeverKorean $ Just "en"
  -- True
  isNeverKorean :: Maybe LanguageTag -> Bool
  isNeverKorean Nothing = False
  isNeverKorean (Just lang') = not (isKorean lang')
  