jbofihe
module Main where
import Network.CGI
import Data.Maybe
import Control.Monad
import System.Process
import System.IO
import Text.XHtml.Strict
import Data.List
import Text.Regex
main :: IO ()
main = runCGI $ handleErrors $ do
loj <- liftM (fromMaybe "") $ getInput "lojban"
big <- getInput "big"
lolcolors <- getInput "lolcolors"
opts <- liftM (intersect jboOpts . map fst) $ getInputs
(err,out) <- formatLojban loj (unwords opts)
output $ showHtml $ page lolcolors (theform lolcolors big loj opts) (pre ! [theclass "err"] << err +++ outStyle out opts)
outStyle :: String -> [String] -> Html
outStyle out opts | any parse opts = pre << out
| any (=="-H") opts = let o = clean out in o +++ pre << o
| otherwise = stringToHtml out
where parse n = n=="-t" || n=="-tf"
clean :: String -> Html
clean = primHtml . remCrap . lines where
remCrap [] = []
remCrap ("<HTML>":h:t:b:k) = subRegex (mkRegex "</BODY>") (unlines k) ""
page :: Maybe a -> Html -> Html -> Html
page lolcolors form output =
header << (thetitle << title +++ css)
+++
body << (h1 << title +++ form +++ hr +++ output)
where title = "jbofihe: Lojban Translator"
css = style "jbofihe-style.css" +++ maybe noHtml (const colors) lolcolors
colors = style "jbofihe-colors.css"
style url = thelink ! [rel "stylesheet", thetype "text/css", href url] << ""
theform :: Maybe a -> Maybe a -> String -> [String] -> Html
theform lolcolors big loj opts =
form << (aCheck lolcolors "lolcolors" "COLORS LOLOL!!!1"
+++
aCheck big "big" "Big text box"
+++ inputBox big loj +++ optChecks opts)
aCheck :: Maybe a -> String -> String -> Html
aCheck big name' capt =
p << (input ! ([thetype "checkbox", name name'] ++ maybeCheck big)
+++ capt)
inputBox :: Maybe a -> String -> Html
inputBox big loj = maybe smallBox bigBox big where
smallBox = p << (t +++ input ! [thetype "text", value loj, name "lojban"] +++ submit)
bigBox _ = p << t +++ p << textarea ! [rows "20", cols "50", value loj, name "lojban"] << loj +++ p << submit
submit = input ! [thetype "submit", value "Translate"]
t = label << "Lojbanic text:"
optChecks :: [String] -> [Html]
optChecks opts = map makeCheck (zip [0..] jboOpts) where
makeCheck (i,n) = p << (check +++ jboOptNames !! i)
where check = input ! ([thetype "checkbox", name n] ++ maybeCheck (find (==n) opts))
maybeCheck :: Maybe a -> [HtmlAttr]
maybeCheck = maybe [] (const [checked])
jboOpts = ["-H","-ie","-re","-se","-sev","-cr","-t","-tf"]
jboOptNames = ["Formatted output"
,"Display elided separators and terminators"
,"Require elidable separators and terminators to be present"
,"Show elidable separators/terminators that could be omitted"
,"Ditto, plus verbose detail"
,"Allow cultural rafsi in lujvo (Reference Grammar section 4.16)"
,"Show edited parse tree"
,"Show full parse tree"]
formatLojban :: String -> String -> CGI (String,String)
formatLojban text opts = liftIO $ do
(hIn,hOut,hErr,p) <- runInteractiveCommand ("jbofihe " ++ opts)
hSetBuffering hIn NoBuffering
hPutStr hIn text
hClose hIn
bad <- hGetContents hErr
good <- hGetContents hOut
return (bad,good)