yokutango-leaflet/yokutango2tex.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}

import Data.Aeson
import Data.String (fromString)
import GHC.Generics
import System.Directory
import System.Environment
import System.FilePath 
import Data.Maybe
import Data.List (intersperse, sort)
import Control.Applicative ((<|>))

import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as T
import qualified Data.Text.Lazy.Encoding as T
import qualified Data.ByteString.Lazy as BS

data NorwegianWord = NorwegianWord { word :: T.Text
                                   , hints :: Maybe [T.Text]
                                   } deriving (Generic, Show)

instance FromJSON NorwegianWord
instance ToJSON NorwegianWord where
    toEncoding = genericToEncoding defaultOptions

data JapaneseWord = JapaneseWord { word :: T.Text
                                 , romaji :: Maybe T.Text 
                                 , hints :: Maybe [T.Text]
                                 } deriving (Generic, Show)

instance FromJSON JapaneseWord
instance ToJSON JapaneseWord where
    toEncoding = genericToEncoding defaultOptions

data Card = Card { norwegian :: [NorwegianWord]
                 , japanese :: [JapaneseWord]
                 } deriving (Generic, Show)

data WordBlock = WordBlock { title :: T.Text
                           , cards :: [Card]
                           } deriving (Show)

instance FromJSON Card
instance ToJSON Card where
    toEncoding = genericToEncoding defaultOptions

data LaTeXRow = LaTeXRow { jw :: T.Text
                         , nw :: T.Text
                         }

(+?) :: Semigroup a => a -> Maybe a -> a
a +? b = case b of
              Nothing -> a
              Just b' -> a <> b'

flipAppend :: T.Text -> T.Text -> T.Text
flipAppend = flip T.append

wrap :: T.Text -> T.Text -> T.Text -> T.Text
wrap s e w = mconcat [s, w, e]

indent :: T.Text -> T.Text
indent = mconcat
       . map (wrap "\t" "\n")
       . T.splitOn "\n"

readJsonFile :: FilePath -> IO (Either String WordBlock)
readJsonFile path = do 
  fileContent <- BS.readFile path
  return $ cardsToWordblock <$> eitherDecode fileContent
  where
    formatPath :: FilePath -> T.Text
    formatPath = T.append "単語 "
               . fromMaybe "???"
               . T.stripPrefix "yokutango_"
               . fromString
               . takeBaseName

    cardsToWordblock cards = WordBlock { title = formatPath path
                                       , cards = cards
                                       }

cardToRow :: Card -> LaTeXRow
cardToRow card = LaTeXRow { jw = japanesePart card
                          , nw = norwegianPart card
                          }
  where
    ruby :: T.Text -> T.Text -> T.Text
    ruby main top = mconcat [ "\\ruby{", main, "}{", top, "}" ]

    subtable :: [T.Text] -> T.Text
    subtable rows = mconcat [ "\\begin{tabular}{@{}l@{}}\n" 
                            , mconcat $ map (\t -> mconcat ["\t", t, " \\\\\n"]) rows
                            , "\\end{tabular}"
                            ]

    hintsToPmatrix :: [T.Text] -> T.Text
    hintsToPmatrix = wrap " $\\begin{pmatrix}" "\\end{pmatrix}$"
                   . mconcat
                   . intersperse " \\\\ "
                   . map (wrap "\\text{" "}")

    jpWordToText :: JapaneseWord -> T.Text
    jpWordToText JapaneseWord { word, romaji, hints } =
      case hints of 
        Nothing -> furiganaBlock
        (Just [hint]) -> mconcat [ furiganaBlock, " (", hint, ")" ]
        (Just hints) -> subtable [mconcat [furiganaBlock, hintsToPmatrix hints ]]
        where
          rubyStr = ruby word <$> romaji
          furiganaBlock = fromMaybe word rubyStr
    
    noWordToText :: NorwegianWord -> T.Text
    noWordToText NorwegianWord { word, hints } =
      case hints of 
        Nothing -> word
        Just [hint] -> mconcat [word, " (", hint, ")"]
        Just hints -> subtable [mconcat [ word, hintsToPmatrix hints]]

    japanesePart :: Card -> T.Text
    japanesePart (Card { japanese = [jpWord] }) = jpWordToText jpWord
    japanesePart (Card { japanese }) = subtable $ map jpWordToText japanese

    norwegianPart :: Card -> T.Text
    norwegianPart (Card { norwegian = [noWord] }) = noWordToText noWord
    norwegianPart (Card { norwegian }) = subtable $ map noWordToText norwegian

wordblockToTable :: WordBlock -> T.Text
wordblockToTable block = mconcat tablePieces
  where
    rows :: [LaTeXRow]
    rows = map cardToRow (cards block)

    rowToText :: LaTeXRow -> T.Text
    rowToText (LaTeXRow { jw, nw }) = indent $ mconcat [ " & ", jw, " & ", nw, " & \\\\\n" ]

    tablePieces :: [T.Text]
    tablePieces = [ "\\section{", title block, "}\n"
                  , "\\begin{longtable}{|l|l@{}|l@{}|l|}\n"
                  , "\\hline\n"
                  , "\\rowcolor{headerColor}\n"
                  , "Status & 日本語 & Norsk & Extra Notes \\\\\n"
                  , "\\hline\n"
                  , "\\endhead\n"
                  , "\\hline"
                  , "\\endfoot"
                  ]
               ++ map rowToText rows
               ++ [ "\\end{longtable}\n" 
                  , "\\newpage\n\n"
                  ]

main :: IO ()
main = do
  dir <- head <$> getArgs
  filePaths <- sort . map (\x -> joinPath [dir, x]) <$> listDirectory dir
  wordBlocks :: Either str [WordBlock] <- sequence <$> mapM readJsonFile filePaths

  let output = case wordBlocks of
                 Right blocks -> mconcat $ map wordblockToTable blocks
                 Left err -> fromString err

  BS.putStr $ T.encodeUtf8 output