content: 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) oo) wss
  
  matchIn p ws = quant (matchPol pol patt) ws where
    quant = if pol then any else all
    (pol,patt) = (head p == '-', tail p)
    matchPol True p w = match p w
    matchPol False p w = not (match p w)
    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 = (flip elem "-~") . 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>"
     ]
  
  