{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_HADDOCK hide #-}

-- | Defines the interfaces for DAUM spell check service.
module Language.Hanspell.DaumSpellChecker
    ( DaumSpellChecker
    , spellCheckByDaum
    , daumSpellCheckerMaxChars
    ) where

import qualified Data.ByteString.UTF8 as BU
import qualified Data.ByteString.Lazy.UTF8 as BLU

import Data.List
import Data.List.Split
import Network.HTTP.Types.Status
import Text.Regex
import Debug.Trace
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class
import Network.HTTP.Client
import Network.HTTP.Client.TLS

import Language.Hanspell.Typo
import Language.Hanspell.Decoder

-- | Defines a class for 'spellCheckByDaum' function overloading.
class Monad m => DaumSpellChecker m where

    -- | Requests spell check to DAUM server, parses the responses,
    -- and returns @m [Typo]@. @spellCheckByDaum@ has two return types.
    -- One is @MaybeT IO [Typo]@, and the other is @IO [Typo]@. 
    --
    -- @
    -- import Language.Hanspell 
    --
    -- example = do
    --     let sentence = "위에계신분, 잘들리세요?"
    --     typos <- spellCheckByDaum sentence
    --     mapM_ (putStrLn . typoToStringWithStyle False) typos
    -- @
    --
    -- The expected output is:
    --
    -- @
    -- 위에계신분, -> 위에 계신 분,
    -- 뒤에 오는 명사를 수식하는 관형격 어미 ‘-ㄴ’, ‘-는’, ‘-던’, ‘-ㄹ’ 등과 의존명사는 띄어 쓰는 것이 옳습니다.
    -- (예)
    -- 노력한 만큼 대가를 얻다.
    -- 소문으로만 들었을 뿐이네.
    -- 합격했다는 소리를 들으니 그저 기쁠 따름이다.
    -- 
    -- 잘들리세요? -> 잘 들리세요?
    -- '익숙하고 능란하게', '좋고 훌륭하게'라는 의미의 부사 '잘'은 띄어 쓰세요.
    -- (예)
    -- 바둑을 잘 두다.
    -- 옷을 잘 차려입고 나서니 딴사람 같구나.
    -- 다음 대화를 잘 듣고 물음에 답하세요.
    -- @ 
    spellCheckByDaum :: String -> m [Typo]

-- | Obssesive version returning @MaybeT IO [Typo]@.
instance DaumSpellChecker (MaybeT IO) where
    spellCheckByDaum :: String -> MaybeT IO [Typo]
spellCheckByDaum String
text = String -> [Typo]
htmlToTypos (String -> [Typo]) -> MaybeT IO String -> MaybeT IO [Typo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> MaybeT IO String
requestToDaum String
text

-- | Bold version returning @IO [Typo]@.
instance DaumSpellChecker IO where
    spellCheckByDaum :: String -> IO [Typo]
spellCheckByDaum String
text = do
        Maybe [Typo]
maybe <- MaybeT IO [Typo] -> IO (Maybe [Typo])
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO [Typo] -> IO (Maybe [Typo]))
-> MaybeT IO [Typo] -> IO (Maybe [Typo])
forall a b. (a -> b) -> a -> b
$ String -> [Typo]
htmlToTypos (String -> [Typo]) -> MaybeT IO String -> MaybeT IO [Typo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> MaybeT IO String
requestToDaum String
text
        case Maybe [Typo]
maybe of 
            Maybe [Typo]
Nothing -> [Typo] -> IO [Typo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Just [Typo]
typos -> [Typo] -> IO [Typo]
forall (m :: * -> *) a. Monad m => a -> m a
return [Typo]
typos

-- | Official maximum character length for a 'spellCheckByDaum' request.
-- Notice that DAUM server can handle more than maximum characters.
daumSpellCheckerMaxChars :: Int
daumSpellCheckerMaxChars :: Int
daumSpellCheckerMaxChars = Int
1000
 
-- 'spellCheckByDaum' prints the message below when the HTTP status code is 
-- not 200. Mainly due to timeout.
daumConnectError :: String
daumConnectError :: String
daumConnectError = 
     String
"-- 한스펠 오류: 다음 서버의 접속 오류로 일부 문장 교정에 실패했습니다."

-- 'spellCheckByDaum' prints the message below when the response is not of 
-- spell checker. Mainly due to the changes of service URL.
invalidResponseFromDaum :: String
invalidResponseFromDaum :: String
invalidResponseFromDaum = 
     String
"-- 한스펠 오류: 다음 서비스가 유효하지 않은 양식을 반환했습니다. (" 
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
daumSpellCheckUrl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" 

-- Daum spell checker URL.
--
-- Try `curl -H "Content-Type: application/x-www-form-urlencoded" \
-- -X POST https://dic.daum.net/grammar_checker.do -d \
-- "sentence=안녕 하세요"`.
daumSpellCheckUrl :: String
daumSpellCheckUrl :: String
daumSpellCheckUrl = String
"https://dic.daum.net/grammar_checker.do"

-- Requests spell check to the server, check the responses, and returns it. 
-- When the status code is not 200, or the response is not of spell checker, 
-- traces error message, and returns Nothing.
requestToDaum :: String -> MaybeT IO String
requestToDaum :: String -> MaybeT IO String
requestToDaum String
text = do
    Manager
manager <- IO Manager -> MaybeT IO Manager
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Manager -> MaybeT IO Manager)
-> IO Manager -> MaybeT IO Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    let pair :: [(ByteString, ByteString)]
pair = [(ByteString
"sentence",String -> ByteString
BU.fromString String
text)]
    Request
initialRequest <- IO Request -> MaybeT IO Request
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Request -> MaybeT IO Request)
-> IO Request -> MaybeT IO Request
forall a b. (a -> b) -> a -> b
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
daumSpellCheckUrl
    let request :: Request
request = ([(ByteString, ByteString)] -> Request -> Request
urlEncodedBody [(ByteString, ByteString)]
pair Request
initialRequest) { method :: ByteString
method = ByteString
"POST" }
    Response ByteString
response <- IO (Response ByteString) -> MaybeT IO (Response ByteString)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Response ByteString) -> MaybeT IO (Response ByteString))
-> IO (Response ByteString) -> MaybeT IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
    let errCode :: Int
errCode = Status -> Int
statusCode (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response)
    let daumResponseInfix :: String
daumResponseInfix = String
"=\"screen_out\">맞춤법 검사기 본문</h2>"
    if Int
errCode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
200
       then let body :: String
body = ByteString -> String
BLU.toString (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response)
             in if String
daumResponseInfix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
body
                   then String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
body
                   else String -> MaybeT IO String -> MaybeT IO String
forall a. String -> a -> a
trace String
invalidResponseFromDaum (IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe String) -> MaybeT IO String)
-> IO (Maybe String) -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing)
       else String -> MaybeT IO String -> MaybeT IO String
forall a. String -> a -> a
trace (String
daumConnectError String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ("String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
errCode String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
            (IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe String) -> MaybeT IO String)
-> IO (Maybe String) -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing)

-- Parses the response HTML to [Typo]
htmlToTypos :: String -> [Typo]
htmlToTypos :: String -> [Typo]
htmlToTypos String
body =
        -- Removes unuseds from body
    let stripped :: String
stripped = [String] -> String
forall a. [a] -> a
head ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"<span class=\"info_byte\">" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
body
        -- Splits the body for each typo
        splitted :: [String]
splitted = [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"data-error-type" (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
stripped
     in (String -> Typo) -> [String] -> [Typo]
forall a b. (a -> b) -> [a] -> [b]
map String -> Typo
htmlToTypo [String]
splitted

-- Parse a unit of response to Typo
htmlToTypo :: String -> Typo
htmlToTypo :: String -> Typo
htmlToTypo String
body = Typo :: String -> String -> [String] -> String -> String -> Typo
Typo { errorType :: String
errorType    =  String -> String
decodeEntity ([String]
splitted[String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
1)
                       , token :: String
token        =  String -> String
decodeEntity ([String]
splitted[String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
3)
                       , suggestions :: [String]
suggestions  = [String -> String
decodeEntity ([String]
splitted[String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
5)]
                       , context :: String
context      =  String -> String
decodeEntity ([String]
splitted[String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
7)
                       , info :: String
info         =  String
info'''
                       } where
    gsub :: String -> String -> String -> String
gsub String
from String
to String
text = Regex -> String -> String -> String
subRegex (String -> Regex
mkRegex String
from) String
text String
to
    splitted :: [String]
splitted = String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"\"" (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
head (String -> [String]
lines String
body)
    info' :: String
info' = String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"<div>" String
body[String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
1
    info'' :: String
info'' = [String] -> String
forall a. [a] -> a
head (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"<span class=\"info_byte\">" String
info')
    info''' :: String
info''' = String -> String -> String -> String
gsub String
"^[ \n][ \n]*" String
""
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
gsub String
"<[^>]*>" String
""
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
gsub String
"<br[^>]*>" String
"\n"
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
gsub String
"</span><span class.*\n" String
""
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
gsub String
"<a href=\"#none\".*\n" String
""
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
gsub String
"^<span>.*\n" String
""
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
gsub String
"<strong class.*\n" String
""
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
gsub String
".*strong class=.tit_help.>예문</strong.*\n" String
"(예)"
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
gsub String
"\t" String
""
            (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
info''