Lib.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Lib
    ( renderMain
    ) where

import Control.Monad.IO.Class (MonadIO(..))
import Data.Char (isAscii)
import Data.List (concat)

import GHCJS.DOM (currentDocument)
import GHCJS.DOM.Document (getElementById)
import GHCJS.DOM.HTMLElement (setInnerText, castToHTMLElement)
import GHCJS.DOM.HTMLTextAreaElement as TextArea
import GHCJS.DOM.Event (Event)
import GHCJS.DOM.EventTarget (addEventListener)
import GHCJS.DOM.EventTargetClosures (eventListenerNewAsync)

-- 入力TextAreaのイベントリスナ(keyup)に
-- update処理を登録する
renderMain :: MonadIO m => m ()
renderMain = do
  Just doc <- liftIO currentDocument
  Just inputTextArea <- getElementById doc "input"
  listener <- liftIO $ eventListenerNewAsync $ \(_ :: Event) -> update
  addEventListener inputTextArea "keyup" (Just listener) False

-- 入力TextAreaから文字列を読み取って変換し、
-- 出力TextAreaに書き込む処理
update :: MonadIO m => m ()
update = do
  Just doc <- liftIO currentDocument
  Just inputTextArea <- getElementById doc "input"
  Just inputString <- TextArea.getValue $ TextArea.castToHTMLTextAreaElement inputTextArea
  Just outputTextArea <- getElementById doc "output"
  let 
    convertedString = convert inputString
  setInnerText (castToHTMLElement outputTextArea) (Just convertedString)

-- 引数の文字列を
-- ＿人人人人人人＿
--
-- ＞　突然の死　＜
-- 
-- ￣Y^Y^Y^Y^Y^Y￣
-- みたいな文字列に変換する関数
convert :: String -> String
convert str = unlines [header, "", main, "", footer]
  where
    lineLength strLine = sum $ map (\c -> if isAscii c then 1 else 2) strLine
    maximumLineWidth = maximum $ map lineLength (lines str)
    wrappingCharacterCount = (maximumLineWidth `div` 2) + 2

    header = "＿" ++ (replicate wrappingCharacterCount '人') ++ "＿"
    main   = "＞　" ++ str ++ "　＜"
    footer = "￣" ++ (concat $ replicate (wrappingCharacterCount - 1) "Y^") ++ "Y￣"