content: {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedLists #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE NamedFieldPuns #-}
  -- | This module deals with Chinese characters and Sino-Korean words written in
  -- hanja.
  module Text.Seonbi.Hanja
      ( -- * Korean mixed-script (國漢文混用) transformation
        HanjaPhoneticization (..)
      , def
      , phoneticizeHanja
        -- * Single character phoneticization
      , phoneticizeHanjaChar
        -- * Word phoneticization
      , HanjaDictionary
      , HanjaWordPhoneticizer
      , phoneticizeHanjaWord
      , phoneticizeHanjaWordWithInitialSoundLaw
      , withDictionary
        -- * Word rendering
      , HanjaWordRenderer
      , hangulOnly
      , hanjaInParentheses
      , hanjaInRuby
        -- * Initial sound law (頭音法則)
      , convertInitialSoundLaw
      , initialSoundLawTable
      , initialSoundLawTable'
      , revertInitialSoundLaw
      ) where
  
  import Prelude hiding (lookup)
  
  import Control.Applicative
  import Control.Monad
  import Data.Char
  import Data.List hiding (lookup)
  import Data.Maybe
  import Data.Ord (comparing)
  
  import Data.Attoparsec.Text
  import Data.Default
  import Data.Map.Strict
  import Data.Set
  import Data.Text hiding (concatMap)
  
  import Text.Seonbi.Hangul
  import Text.Seonbi.Html
  import Text.Seonbi.Html.Lang
  import Text.Seonbi.Html.Preservation
  import Text.Seonbi.Html.TagStack (push)
  import qualified Text.Seonbi.Trie as Trie
  import Text.Seonbi.Unihan.KHangul
  
  -- $setup
  -- >>> import qualified Text.Show.Unicode
  -- >>> :set -interactive-print=Text.Show.Unicode.uprint
  
  -- | Settings to transform Sino-Korean words written in hanja into hangul
  -- letters.
  data HanjaPhoneticization = HanjaPhoneticization
      { -- | A function to phoneticize a hanja word.
        -- Use 'phoneticizeHanjaWordWithInitialSoundLaw' for South Korean
        -- orthography, or 'phoneticizeHanjaWord' for North Korean orthography.
        phoneticizer :: HanjaWordPhoneticizer
        -- | A function to render a hanja word.  See also 'HanjaWordRenderer'.
      , wordRenderer :: HanjaWordRenderer
        -- | A function to render a hanja word which should be disambiguated.
        -- It's used instead of 'wordRenderer' when two or more words in
        -- a text have the same hangul reading but actually are dictinct
        -- each other in hanja characters, e.g., 小數\/素數 (소수).
      , homophoneRenderer :: HanjaWordRenderer
        -- | Whether to insert some HTML comments that contain useful information
        -- for debugging into the result.  This does not affect the rendering
        -- of the result HTML, but only the HTML code.
      , debugComment :: Bool
      }
  
  -- | A function to phoneticize a Sino-Korean (i.e., hanja) word (漢字語)
  -- into hangul letters.
  -- See also 'phoneticizeHanjaWord', 'phoneticizeHanjaWordWithInitialSoundLaw',
  -- and 'withDictionary'.
  type HanjaWordPhoneticizer
      = Text  -- ^ A Sino-Korean (i.e., hanja) word (漢字語) to phoneticize.
      -> Text -- ^ Hangul letters that phoneticize the given Sino-Korean word.
  
  -- | A function to render a Sino-Korean (i.e., hanja) word (漢字語).
  -- Choose one in 'hangulOnly', 'hanjaInParentheses', and 'hanjaInRuby'.
  type HanjaWordRenderer
      = HtmlTagStack
      -- ^ Where rendered HTML entities get interleaved into.
      -> Text
      -- ^ A Sino-Korean (i.e., hanja) word (漢字語) to render.
      -> Text
      -- ^ Hangul letters that phoneticized the Sino-Korean word.
      -> [HtmlEntity]
      -- ^ Rendered HTML entities.
  
  -- | Renders a word in hangul-only, no hanja at all (e.g., @안녕히@).
  hangulOnly :: HanjaWordRenderer
  hangulOnly stack _ hangul = [HtmlCdata stack hangul]
  
  -- | Renders a word in hangul followed by hanja in parentheses
  -- (e.g., @안녕(安寧)히@).
  hanjaInParentheses :: HanjaWordRenderer
  hanjaInParentheses stack hanja hangul =
      [HtmlCdata stack $ Data.Text.concat [hangul, "(", hanja, ")"]]
  
  -- | Renders a word in @<ruby>@ tag (e.g.,
  -- @\<ruby\>安寧\<rp\>(\<\/rp\>\<rt\>안녕\<\/rt\>\<rp\>)\<\/rp\>\<\/ruby\>히@).
  --
  -- Please read [Use Cases & Exploratory Approaches for Ruby
  -- Markup](https://www.w3.org/TR/ruby-use-cases/) as well for more information.
  hanjaInRuby :: HanjaWordRenderer
  hanjaInRuby stack hanja hangul =
      [ HtmlStartTag stack Ruby ""
      , HtmlCdata rubyStack hanja
      , HtmlStartTag rubyStack RP ""
      , HtmlText (push RP rubyStack) "("
      , HtmlEndTag rubyStack RP
      , HtmlStartTag rubyStack RT ""
      , HtmlCdata (push RT rubyStack) hangul
      , HtmlEndTag rubyStack RT
      , HtmlStartTag rubyStack RP ""
      , HtmlText (push RP rubyStack) ")"
      , HtmlEndTag rubyStack RP
      , HtmlEndTag stack Ruby
      ]
    where
      rubyStack :: HtmlTagStack
      rubyStack = push Ruby stack
  
  instance Default HanjaPhoneticization where
      def = HanjaPhoneticization
          { phoneticizer = phoneticizeHanjaWordWithInitialSoundLaw
          , wordRenderer = hangulOnly
          , homophoneRenderer = hanjaInParentheses
          , debugComment = False
          }
  
  -- | Transforms hanja words in the given HTML entities into corresponding
  -- hangul words.
  phoneticizeHanja
      :: HanjaPhoneticization
      -- ^ Configures the phoneticization details.
      -> [HtmlEntity]
      -- ^ HTML entities (that may contain some hanja words) to phoneticize
      -- all hanja words into corresponding hangul-only words.
      -> [HtmlEntity]
      -- ^ HTML entities that have no hanja words but hangul-only words instead.
  phoneticizeHanja HanjaPhoneticization { phoneticizer
                                        , wordRenderer
                                        , homophoneRenderer
                                        , debugComment
                                        }
                   entities =
      (`concatMap` normalized) $ \ case
          Left e' ->
              [e']
          Right (stack, hanja, hangul) ->
              if Data.Set.size (findWithDefault [] hangul frequencyDict) > 1
              then homophoneRenderer' stack hanja hangul
              else wordRenderer' stack hanja hangul
    where
      frequencyDict :: Map Text (Set Text)
      frequencyDict = Data.Map.Strict.fromListWith
          Data.Set.union
          [(hangul, [hanja]) | Right (_, hanja, hangul) <- normalized]
      normalized :: [Either HtmlEntity (HtmlTagStack, Text, Text)]
      normalized = Data.List.concat
          [ case e of
              Left _ ->
                  [e]
              Right (stack, hanja, hangul) ->
                  let hanjaWords = splitByDigits hanja
                      hangulWords = splitByDigits hangul
                      hanjaWordsLen = Prelude.length hanjaWords
                      hangulWordsLen = Prelude.length hangulWords
                  in
                      if hanjaWordsLen /= hangulWordsLen
                      then [e]
                      else
                          [ if Data.Text.any isDigit hanj
                            then Left $ HtmlText stack hanj
                            else Right (stack, hanj, hang)
                          | (hanj, hang) <- Prelude.zip hanjaWords hangulWords
                          ]
          | e <- concatMap transform (annotateWithLang entities)
          ]
      splitByDigits :: Text -> [Text]
      splitByDigits = Data.Text.groupBy (\ a b -> isDigit a == isDigit b)
      transform :: LangHtmlEntity
                -> [Either HtmlEntity (HtmlTagStack, Text, Text)]
      transform LangHtmlEntity
                  { lang = lang
                  , entity = entity@HtmlText
                      { tagStack = tagStack'
                      , rawText = rawText'
                      }
                  }
        | isPreservedTagStack tagStack' || isNeverKorean lang =
              [Left entity]
        | otherwise =
              case analyzeHanjaText rawText' of
                  Nothing -> [Left $ entity { rawText = rawText' }]
                  Just pairs ->
                      [ if trueIfHanja
                        then Right (tagStack', htmlText, phoneticizer htmlText)
                        else Left (entity { rawText = htmlText })
                      -- Note that htmlText here can have HTML entities.
                      | (trueIfHanja, htmlText) <- pairs
                      ]
      transform LangHtmlEntity { entity } =
          [Left entity]
      -- FIXME: This should be public:
      debugRenderer :: HanjaWordRenderer -> HanjaWordRenderer
      debugRenderer render stack hanja hangul =
          HtmlComment stack (" Hanja: " `append` hanja)
              : render stack hanja hangul ++ [HtmlComment stack " /Hanja "]
      wordRenderer' :: HanjaWordRenderer
      wordRenderer'
        | debugComment = debugRenderer wordRenderer
        | otherwise = wordRenderer
      homophoneRenderer' :: HanjaWordRenderer
      homophoneRenderer'
        | debugComment = debugRenderer homophoneRenderer
        | otherwise = homophoneRenderer
  
  analyzeHanjaText :: Text -> Maybe [(Bool, Text)]
  analyzeHanjaText text' =
      case parseOnly (textParser <* endOfInput) text' of
          Left _ -> Nothing
          Right pairs -> Just
              [ (trueIfHanja, text)
              | (trueIfHanja, text) <- pairs
              , not (Data.Text.null text)
              ]
  
  -- | Reads a hanja word and returns a corresponding hangul word.
  --
  -- >>> :set -XOverloadedStrings
  -- >>> phoneticizeHanjaWord "漢字"
  -- "한자"
  --
  -- Note that it does not apply Initial Sound Law (頭音法則):
  --
  -- >>> phoneticizeHanjaWord  "來日"
  -- "래일"
  phoneticizeHanjaWord :: HanjaWordPhoneticizer
  phoneticizeHanjaWord =
      Data.Text.map phoneticizeHanjaChar
  
  -- | It is like 'phoneticizeHanjaWord', but it also applies
  -- Initial Sound Law (頭音法則).
  --
  -- >>> :set -XOverloadedStrings
  -- >>> phoneticizeHanjaWordWithInitialSoundLaw  "來日"
  -- "내일"
  -- >>> phoneticizeHanjaWordWithInitialSoundLaw  "未來"
  -- "미래"
  phoneticizeHanjaWordWithInitialSoundLaw :: HanjaWordPhoneticizer
  phoneticizeHanjaWordWithInitialSoundLaw word =
      case parseOnly (parser <* endOfInput) word of
          Left _ -> word
          Right "" -> word
          Right hangulWord -> hangulWord
    where
      parser :: Parser Text
      parser = do
          chars <- many'
              ( try yeolYul
              <|> try prefixedNumber
              <|> try hanNumber
              <|> try (Data.Text.singleton . phoneticize <$> anyChar)
              )
          let hangulWord = Data.Text.concat chars
          return $ Data.Text.concat
              [ Data.Text.map convertInitialSoundLaw $ Data.Text.take 1 hangulWord
              , Data.Text.drop 1 hangulWord
              ]
      yeolYul :: Parser Text
      yeolYul = do
          former <- satisfy $ \ c ->
              c `hasBatchim` Just '\x11ab' || c `hasBatchim` Nothing
          later <- phone '렬' <|> phone '률'
          return $ pack
              [ phoneticize former
              , convert later
              ]
      prefixedNumber :: Parser Text
      prefixedNumber = do
          prefix <- char '第'
          digits <- takeWhile1 isHanDigit
          return $ Data.Text.cons
              (phoneticize prefix)
              (Data.Text.map convertDigit digits)
      hanNumber :: Parser Text
      hanNumber = do
          first <- hanDigit
          rest <- takeWhile1 isHanDigit
          return $ Data.Text.map convertDigit $ Data.Text.cons first rest
      hanDigit :: Parser Char
      hanDigit = satisfy isHanDigit
      phone :: Char -> Parser Char
      phone hangul = satisfy ((== hangul) . phoneticize)
      convertDigit :: Char -> Char
      convertDigit = convertInitialSoundLaw . phoneticizeDigit
      convert :: Char -> Char
      convert = convertInitialSoundLaw . phoneticize
      phoneticizeDigit :: Char -> Char
      phoneticizeDigit '參' = '삼'
      phoneticizeDigit '叁' = '삼'
      phoneticizeDigit '参' = '삼'
      phoneticizeDigit '叄' = '삼'
      phoneticizeDigit '拾' = '십'
      phoneticizeDigit c = phoneticize c
      phoneticize :: Char -> Char
      phoneticize = phoneticizeHanjaChar
      hasBatchim :: Char -> Maybe Char -> Bool
      hasBatchim c batchim =
          case toJamoTriple (phoneticize c) of
              Just (_, _, final) -> final == batchim
              _ -> False
      isHanDigit :: Char -> Bool
      isHanDigit = inClass $
          "零一壹壱弌夁二貳贰弐弍貮三參叁参弎叄四肆䦉五伍六陸陆陸七柒漆八捌" ++
          "九玖十拾百佰陌千仟阡萬万億兆京垓秭穰溝澗"
  
  -- | Represents a dictionary that has hanja keys and values of their
  -- corresponding hangul readings, e.g., @[("敗北", "패배")]@.
  type HanjaDictionary = Trie.Trie Text
  
  -- | Reads a hanja word according to the given dictionary, or falls back to
  -- the other phoneticizer if there is no such word in the dictionary.
  --
  -- It's basically replace one with one:
  --
  -- >>> :set -XOverloadedLists -XOverloadedStrings
  -- >>> let phone = withDictionary [("自轉車", "자전거")] phoneticizeHanjaWord
  -- >>> phone "自轉車"
  -- "자전거"
  --
  -- But, if it faces any words or characters that are not registered in
  -- the dictionary, it does the best to interpolate prefixes\/infixes\/suffixes
  -- using the fallback phoneticizer:
  --
  -- >>> phone "自轉車道路"
  -- "자전거도로"
  -- >>> phone "二輪自轉車"
  -- "이륜자전거"
  withDictionary
      :: HanjaDictionary
      -- ^ Hangul readings of Sino-Korean words.
      -> HanjaWordPhoneticizer
      -- ^ A fallback phoneticize for unregistered words.
      -- E.g., 'phoneticizeHanjaWordWithInitialSoundLaw'.
      -> HanjaWordPhoneticizer
      -- ^ A combined phoneticizer.
  withDictionary _ _ "" = ""
  withDictionary dic fallback word =
      case matches of
          [] ->
              fallback word
          (replaced, rest) : _ ->
              if Data.Text.null rest
              then replaced
              else replaced `append` withDictionary dic fallback rest
    where
      lookupDic :: Text -> Maybe Text
      lookupDic = (`Trie.lookup` dic)
      tries :: [(Text, Text)]
      tries =
          [Data.Text.splitAt pos word | pos <- [0..Data.Text.length word]]
      patterns :: Text -> [Text]
      patterns word' =
          word' : case unsnoc word' of
              Just (next, _) -> patterns next
              Nothing -> []
      matchTries :: [Maybe (Text, Text, Text)]
      matchTries =
          (`Prelude.map` tries) $ \ (unmatched, wd) ->
              case [(p, m) | p <- patterns wd, m <- maybeToList (lookupDic p)] of
                  [] -> Nothing
                  pair : _ -> Just
                      ( unmatched
                      , snd pair
                      , Data.Text.drop (Data.Text.length $ fst pair) wd
                      )
      matches :: [(Text, Text)]
      matches =
          [ (fallback unmatched `append` matched, rest)
          | Just (unmatched, matched, rest) <- matchTries
          ]
  
  -- | Reads a hanja character as a hangul character.
  --
  -- >>> phoneticizeHanjaChar '漢'
  -- '한'
  --
  -- Note that it does not follow Initial Sound Law (頭音法則):
  --
  -- >>> phoneticizeHanjaChar '六'
  -- '륙'
  phoneticizeHanjaChar :: Char -> Char
  phoneticizeHanjaChar c = fromMaybe c $ do
      readings <- lookup c kHangulData
      let readings' = Data.Map.Strict.toList readings
      let (sound, _) = minimumBy (comparing snd) readings'
      let initialLawReverted = Data.Set.filter
              (`Data.Map.Strict.member` readings)
              (revertInitialSoundLaw sound)
      return $ case Data.Set.toList initialLawReverted of
          [] -> sound
          reverted : _ -> reverted
  
  withoutBatchim :: Char -> Maybe (Char, Maybe Char)
  withoutBatchim hangul = do
      (initial, vowel, final) <- toJamoTriple hangul
      noBatchim <- fromJamoTriple (initial, vowel, Nothing)
      return (noBatchim, final)
  
  withBatchim :: Char -> Maybe Char -> Maybe Char
  withBatchim hangul final = do
      (initial, vowel, _) <- toJamoTriple hangul
      fromJamoTriple (initial, vowel, final)
  
  -- | Converts a hangul character according to Initial Sound Law (頭音法則).
  --
  -- >>> convertInitialSoundLaw '념'
  -- '염'
  --
  -- If an input is not a hangul syllable or a syllable is not applicable to
  -- the law it returns the given input without change:
  --
  -- >>> convertInitialSoundLaw 'A'
  -- 'A'
  -- >>> convertInitialSoundLaw '가'
  -- '가'
  convertInitialSoundLaw :: Char -> Char
  convertInitialSoundLaw sound = fromMaybe sound $ do
      (pattern', final) <- withoutBatchim sound
      let converted = findWithDefault pattern' pattern' initialSoundLawTable
      withBatchim converted final
  
  -- | It's a kind of inverse function of 'convertInitialSoundLaw',
  -- except it returns a set of candidates instead of a single canonical answer
  -- because Initial Sound Law (頭音法則) is not a bijective function.
  --
  -- >>> revertInitialSoundLaw '예'
  -- fromList "례"
  -- >>> revertInitialSoundLaw '염'
  -- fromList "념렴"
  --
  -- It returns an empty set if an input is not applicable to the law:
  --
  -- >>> revertInitialSoundLaw '가'
  -- fromList ""
  revertInitialSoundLaw :: Char -> Set Char
  revertInitialSoundLaw sound = fromMaybe Data.Set.empty $ do
      (pattern', final) <- withoutBatchim sound
      let candidates = Data.Set.toList $
              findWithDefault Data.Set.empty pattern' initialSoundLawTable'
      Just $ Data.Set.fromList $ catMaybes $ candidates <&> (`withBatchim` final)
    where
      (<&>) :: Functor f => f a -> (a -> b) -> f b
      (<&>) = flip fmap
  
  textParser :: Parser [(Bool, Text)]
  textParser = fmap Data.List.concat $ many' $ do
      -- We have 3 passes to optimize by utilizing takeWhile instead of many'
      hanjaEntities <- many' $ try $ do
          c <- unnamedCharRef
          unless (isHanjaOrDigit c) (fail "not a hanja")
          return c
      hanjaCharsText <- Data.Attoparsec.Text.takeWhile isHanjaOrDigit
      hanjaChars <- many' $ try $ do
          c <- unnamedCharRef <|> anyChar
          unless (isHanjaOrDigit c) (fail "not a hanja")
          return c
      -- Note that the parsed result can still have HTML entities; these
      -- are never touched.
      entities <- many' $ try $ do
          c <- unnamedCharRef
          when (isHanjaOrDigit c) (fail "a hanja")
          return c
      charsText <- takeTill isHanjaOrDigit
      chars <- many' $ try $ do
          c <- unnamedCharRef <|> anyChar
          when (isHanjaOrDigit c) (fail "a hanja")
          return c
      let hanjaText = Data.Text.concat
              [pack hanjaEntities, hanjaCharsText, pack hanjaChars]
      let text' = Data.Text.concat [pack entities, charsText, pack chars]
      when (Data.Text.null $ hanjaText `append` text') (fail "parsed nothing")
      return [(True, hanjaText), (False, text')]
    where
      isHanjaOrDigit :: Char -> Bool
      isHanjaOrDigit c =
          isDigit c || isHanja c
      isHanja :: Char -> Bool
      isHanja c =
          -- Ideographic Description Character
          '\x2f00'  <= c && c <= '\x2fff' ||
          -- U+3007 IDEOGRAPHIC NUMBER ZERO (〇)
          '\x3007'  == c ||
          -- CJK Unified Ideographs Extension A
          '\x3400'  <= c && c <= '\x4dbf' ||
          -- CJK Unified Ideographs
          '\x4e00'  <= c && c <= '\x9fcc' ||
          -- CJK Compatibility Ideographs
          '\xf900'  <= c && c <= '\xfaff' ||
          -- CJK Unified Ideographs Extension B
          '\x20000' <= c && c <= '\x2a6d6' ||
          -- CJK Unified Ideographs Extension C
          '\x2a700' <= c && c <= '\x2b734' ||
          -- CJK Unified Ideographs Extension D
          '\x2b740' <= c && c <= '\x2b81d' ||
          -- CJK Unified Ideographs Extension E
          '\x2b820' <= c && c <= '\x2cea1' ||
          -- CJK Unified Ideographs Extension F
          '\x2ceb0' <= c && c <= '\x2ebe0' ||
          -- CJK Compatibility Ideographs Supplement
          '\x2f800' <= c && c <= '\x2fa1f'
      unnamedCharRef :: Parser Char
      unnamedCharRef = do
          _ <- char '&'
          _ <- char '#'
          hex <- option False ((char 'x' <|> char 'X') >> return True)
          codepoint <- if hex then hexadecimal else decimal
          _ <- char ';'
          return $ chr codepoint
  
  -- | The Initial Sound Law (頭音法則) table according to South Korean
  -- /Hangul Orthography/ (한글 맞춤법) Clause 5, Section 52, Chapter 6
  -- (第6章52項5節).  Keys are an original Sino-Korean sound and values
  -- are a converted sound according to the law.
  initialSoundLawTable :: Map Char Char
  initialSoundLawTable =
      [ ('녀', '여')
      , ('뇨', '요')
      , ('뉴', '유')
      , ('니', '이')
      , ('랴', '야')
      , ('려', '여')
      , ('례', '예')
      , ('료', '요')
      , ('류', '유')
      , ('리', '이')
      , ('라', '나')
      , ('래', '내')
      , ('로', '노')
      , ('뢰', '뇌')
      , ('루', '누')
      , ('르', '느')
      ]
  
  -- | Contains the same contents to 'initialSoundLawTable' except that
  -- keys and values are crossed: keys are a converted sound and values are
  -- possible original sounds.
  initialSoundLawTable' :: Map Char (Set Char)
  initialSoundLawTable' =
      foldrWithKey f Data.Map.Strict.empty initialSoundLawTable
    where
      f :: Char -> Char -> Map Char (Set Char) -> Map Char (Set Char)
      f original converted =
          insertWith Data.Set.union converted (Data.Set.singleton original)
  