Transform a Japanese word to furigana

Question

I developed a script to transform a Japanese word in Furigana thanks to the jisho website. But the code is very ugly, especially the extractHiraganaFromHTML and filterBetween functions. What kind of improvements are possible?

module Main
where

import Network.HTTP
import Network.URI
import Text.HTML.TagSoup
import Data.Text (unpack)
import Data.Text.Encoding (decodeUtf8)
import Data.ByteString.Char8 (pack)
import System.Environment (getArgs)

jishoUrlFor :: String -> String 
jishoUrlFor word = (escapeURIString isUnescapedInURI) $ "http://jisho.org/word/"++word

getJishoHTML :: String -> IO String
getJishoHTML w  = simpleHTTP (getRequest $ jishoUrlFor w) >>=  getResponseBody

extractHiraganaFromHTML :: String -> String
extractHiraganaFromHTML = unicodeToString . strip . innerText . filter(~== TagText "") . filterBetween . head . partitions  (~== "<span class=\"furigana\">") . parseTags

convertWordToHiragana :: String -> IO String 
convertWordToHiragana w = do 
    html <- getJishoHTML w
    return $ extractHiraganaFromHTML html 


filterBetween :: [Tag String] -> [Tag String]
filterBetween p = fst $ sfoldl step ([],0) $  p
where step (x,a) tag | tag ~== "<span>" = (tag:x,a+1)             
      step (x,a) tag | tag ~== TagClose "span" = (tag:x,a-1)
      step (x,a) tag = (tag:x,a)

      sfoldl step (a,1) (TagClose "span":xs) = (reverse (TagClose "span":a),0) -- stop condition
      sfoldl step (a,b) (x:xs) = sfoldl step (step (a,b) x) xs 
      sfoldl step (a,b) [] = (a,b)



wchars = " \t\r\n"

strip :: String -> String
strip = lstrip . rstrip

lstrip :: String -> String
lstrip = dropWhile (`elem` wchars)

rstrip :: String -> String
rstrip = reverse . lstrip . reverse

unicodeToString = Data.Text.unpack . Data.Text.Encoding.decodeUtf8 . Data.ByteString.Char8.pack

main = do
    (word:_) <- getArgs
    a <- convertWordToHiragana word
    putStrLn a

Answer 1

Let's inline stuff that's only used once and replace recursion with library combinators.

import Control.Monad.State (evalState, modify, gets)
import Control.Monad.Loops (takeWhileM)
import Control.Applicative ((*>))
import Data.Char (isSpace)

filterBetween :: [Tag String] -> [Tag String]
filterBetween = (`evalState` 1) . takeWhileM step where
  step tag = modify (+ bracket tag) *> gets (>0)
  bracket tag
    | tag ~== "<span>" = 1
    | tag ~== TagClose "span" = -1
    | otherwise = 0

main = do
  [word] <- getArgs
  http <- simpleHTTP $ getRequest $ escapeURIString isUnescapedInURI $ "http://jisho.org/word/" ++ word
  html <- getResponseBody http
  putStrLn
    $ Data.Text.unpack $ Data.Text.Encoding.decodeUtf8 $ Data.ByteString.Char8.pack
    $ dropWhile isSpace $ reverse $ dropWhile isSpace $ reverse
    $ innerText $ filter (~== TagText "")
    $ filterBetween
    $ tail $ head $ partitions (~== "<span class=\"furigana\">") $ parseTags html

I left the <span> and </span> tags themselves out of what is printed, that's easier to code up so might be the correct way.

Edit: More existing combinators :D

{-# LANGUAGE OverloadedStrings #-}
import Text.HTML.TagSoup.Match (getTagContent)
import Data.Text (strip)
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.IO as T

main = do
  [word] <- getArgs
  http <- simpleHTTP $ getRequest $ escapeURIString isUnescapedInURI
    $ "http://jisho.org/word/" ++ word
  html <- getResponseBody http
  T.putStrLn $ strip $ decodeUtf8 $ innerText
    $ getTagContent "span" (== [("class","furigana")]) $ parseTags html

Answer 2

Working with text is easier with Data.Text. E.g. it has strip already defined.

Tagsoup understands Data.Text so you don't need many type conversions.

For greater amounts of data it will be notably faster and much more memory efficient.

Instead of defining filterBetween you can convert tag stream into tag tree, take first node and convert it back to stream:

import Text.HTML.TagSoup.Tree (tagTree, flattenTree)
filterBetween = flattenTree . take 1 . tagTree

It is really better to have many small and named functions with type annotations. This not only documents code but also helps to localize type errors while developing.

Please note qualified imports. It is considered idiomatic to import qualified modules like Data.Text, Data.ByteString, Data.Map and some other. This prevents name clashes with Prelude.

import Control.Monad ((>=>))
import Data.Maybe (fromJust)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as T
import Network.HTTP
import Network.URI
import Text.HTML.TagSoup
import Text.HTML.TagSoup.Tree (tagTree, flattenTree)
import System.Environment (getArgs)


wordUri :: String -> URI
wordUri word = fromJust
  $ parseURI
  $ "http://jisho.org/word/" ++ escapeURIString isUnescapedInURI word

getJishoHTML :: String -> IO Text
getJishoHTML w
  = simpleHTTP (mkRequest GET $ wordUri w)
  >>= fmap T.decodeUtf8 . getResponseBody

hiraganaFromHTML :: Text -> [Text]
hiraganaFromHTML
  = map (T.strip . innerText . flattenTree . take 1 . tagTree)
  . partitions (~== "<span class=\"furigana\">")
  . parseTags

wordToHiragana :: String -> IO [Text]
wordToHiragana = fmap hiraganaFromHTML . getJishoHTML

main :: IO ()
main = getArgs >>= mapM_ (wordToHiragana >=> T.putStrLn . head)