diff options
| author | aarne <aarne@chalmers.se> | 2012-09-12 12:52:03 +0000 |
|---|---|---|
| committer | aarne <aarne@chalmers.se> | 2012-09-12 12:52:03 +0000 |
| commit | acb3fa961e6a9e548addabf34796f7645832c884 (patch) | |
| tree | 02c7cd92ee65ea7e45fb477692f6813d4c1a35fa /src/www/gfmorpho/GFMorpho.hs | |
| parent | 38db61e34f53c6245f38915d272362ca34711d91 (diff) | |
First version of a web server for morphological paradigms.
Diffstat (limited to 'src/www/gfmorpho/GFMorpho.hs')
| -rw-r--r-- | src/www/gfmorpho/GFMorpho.hs | 108 |
1 files changed, 108 insertions, 0 deletions
diff --git a/src/www/gfmorpho/GFMorpho.hs b/src/www/gfmorpho/GFMorpho.hs new file mode 100644 index 000000000..e01d1da56 --- /dev/null +++ b/src/www/gfmorpho/GFMorpho.hs @@ -0,0 +1,108 @@ +import Network.HTTP.Base +import Codec.Binary.UTF8.String +import Data.Char +import Data.List +import System + +main = do + xs <- getArgs + let xxoo = lexArgs (unwords xs) + case pArgs xxoo of + Just (oo,xx) -> do + morpho oo xx + _ -> do + putStrLn $ "cannot read " ++ unwords xs ++ "." + putStrLn "<p>" + putStrLn usage + +usage = "usage: gfmorpho LANG POS FORMS OPT*" + +noParse xx = length xx < 3 ---- + +lexArgs = map (decodeString . urlDecode) . words . map unspec . drop 1 . dropWhile (/='=') where + unspec c = case c of + '=' -> ' ' + '+' -> ' ' + _ -> c + +pArgs xxoo = do + let (oo,xx) = partition isOption xxoo + if length xx < 3 then Nothing else return (oo,xx) + +morpho :: [String] -> [String] -> IO () +morpho oo xx = do + writeFile tmpCommand (script xx) + system $ command xx + s <- readFile tmpFile + putStrLn $ mkFile $ response oo s + +script ("!":lang:rest) = "cc -table -unqual " ++ unwords rest +script (lang: pos: forms) = "cc -table -unqual " ++ fun pos ++ quotes forms + where + fun pos = "mk" ++ pos + +command ("!":args) = command args +command (lang: pos: forms) = + "/usr/local/bin/gf -run -retain -path=alltenses alltenses/Paradigms" ++ lang ++ ".gfo" + ++ " < " ++ tmpCommand + ++ " > " ++ tmpFile + +quotes = unwords . map quote where + quote s = case s of + '_':tag -> tag + _ -> "\"" ++ s ++ "\"" + +-- html response +response oo = + tag "table border=1" . unlines . map (tag "tr" . unwords) . map cleanTable . grep oo . map words . lines + +cleanTable ws = [tag "td" (unwords param), tag "td" (tag "i" (unwords form))] where + (param,form) = getOne (map cleant ws) + cleant w = case w of + "s" -> "" + "." -> "" + _ -> cleanw w + cleanw = filter (flip notElem "()") + getOne ws = let ww = filter (/= "=>") ws in (init ww, [last ww]) -- excludes multiwords + +responsePlain oo = + unlines . map unwords . grep oo . map cleanTablePlain . map words . lines + +cleanTablePlain = map clean where + clean w = case w of + "=>" -> "\t" + "s" -> "" + "." -> "" + _ -> cleanw w + cleanw = filter (flip notElem "()") + +grep oo wss = filter (\ws -> all (flip matchIn ws) (map tail oo)) wss + +matchIn p ws = any (match p) ws where + match p w = case (p,w) of + ('*':ps,_ ) -> any (match ps) [drop i w | i <- [0..length w]] --- + (c:ps, d:ws) -> c == d && match ps ws + _ -> p == w + +tmpFile = "_gfmorpho.tmp" +tmpCommand = "_gfcommand.tmp" + +isOption = (=='-') . head + +tag t s = "<" ++ t ++ ">" ++ s ++ "</" ++ t ++ ">" + + +-- html file with UTF8 + +mkFile s = unlines $ [ + "<HTML>", + "<HEAD>", + "<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=utf-8\">", + "<TITLE>GF Smart Paradigm Output</TITLE>", + "</HEAD>", + "<BODY>", + s, + "</BODY>", + "</HTML>" + ] + |