{-# LANGUAGE DeriveDataTypeable #-}

import PGF (PGF)
import qualified PGF
import FastCGIUtils
import URLEncoding

import Network.CGI
import Text.JSON
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)

import Control.Monad
import qualified Data.Map as Map
import Data.Maybe


grammarFile :: FilePath
grammarFile = "grammar.pgf"



main :: IO ()
main = do initFastCGI
          r <- newDataRef
          loopFastCGI (handleErrors (handleCGIErrors (fcgiMain r)))

fcgiMain :: DataRef PGF -> CGI CGIResult
fcgiMain ref = getData (liftIO . PGF.readPGF) ref grammarFile >>= cgiMain

cgiMain :: PGF -> CGI CGIResult
cgiMain pgf =
    do path <- pathInfo
       json <- case path of
         "/parse"          -> return (doParse pgf) `ap` getText `ap` getCat `ap` getFrom
         "/complete"       -> return (doComplete pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getLimit
         "/linearize"      -> return (doLinearize pgf) `ap` getTree `ap` getTo
         "/translate"      -> return (doTranslate pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo
         "/categories"     -> return $ doCategories pgf
         "/languages"      -> return $ doLanguages pgf
         _                 -> throwCGIError 404 "Not Found" ["Resource not found: " ++ path]
       outputJSON json
  where
    getText :: CGI String
    getText = liftM (maybe "" urlDecodeUnicode) $ getInput "input"

    getTree :: CGI PGF.Tree
    getTree = do mt <- getInput "tree"
                 t <- maybe (throwCGIError 400 "No tree given" ["No tree given"]) return mt
                 maybe (throwCGIError 400 "Bad tree" ["Bad tree: " ++ t]) return (PGF.readTree t)

    getCat :: CGI (Maybe PGF.Category)
    getCat = 
       do mcat  <- getInput "cat"
          case mcat of
            Just "" -> return Nothing
            Just cat | cat `notElem` PGF.categories pgf ->
                         throwCGIError 400 "Unknown category" ["Unknown category: " ++ cat]
            _ -> return mcat

    getFrom :: CGI (Maybe PGF.Language)
    getFrom = getLang "from"

    getTo :: CGI (Maybe PGF.Language)
    getTo = getLang "to"

    getLimit :: CGI (Maybe Int)
    getLimit = readInput "limit"

    getLang :: String -> CGI (Maybe PGF.Language)
    getLang i = 
       do mlang <- getInput i
          case mlang of
            Just "" -> return Nothing
            Just lang | lang `notElem` PGF.languages pgf ->
                          throwCGIError 400 "Unknown language" ["Unknown language: " ++ lang]
            _ -> return mlang

doTranslate :: PGF -> String -> Maybe PGF.Category -> Maybe PGF.Language -> Maybe PGF.Language -> JSValue
doTranslate pgf input mcat mfrom mto = showJSON $ map toJSObject
     [[("from",from),("to",to),("text",output)]
           | (from,trees) <- parse' pgf input mcat mfrom,
             tree <- trees,
             (to,output) <- linearize' pgf mto tree]

doParse :: PGF -> String -> Maybe PGF.Category -> Maybe PGF.Language -> JSValue
doParse pgf input mcat mfrom = showJSON $ map toJSObject
     [[("from",from),("tree",PGF.showTree tree)]
         | (from,trees) <- parse' pgf input mcat mfrom,
           tree <- trees ]

doComplete :: PGF -> String -> Maybe PGF.Category -> Maybe PGF.Language -> Maybe Int -> JSValue
doComplete pgf input mcat mfrom mlimit = showJSON $ map toJSObject $ limit
     [[("from",from),("text",text)]
          | (from,compls) <- complete' pgf input mcat mfrom,
            text <- compls]
  where
    limit xs = maybe xs (\n -> take n xs) mlimit

doLinearize :: PGF -> PGF.Tree -> Maybe PGF.Language -> JSValue
doLinearize pgf tree mto = showJSON $ map toJSObject
     [[("to",to),("text",text)] | (to,text) <- linearize' pgf mto tree]

doLanguages :: PGF -> JSValue
doLanguages pgf = showJSON $ map toJSObject
     [[("lang", showJSON l), 
      ("languageCode", showJSON $ fromMaybe "" (PGF.languageCode pgf l)),
      ("canParse",     showJSON $ PGF.canParse pgf l)]
          | l <- PGF.languages pgf]

doCategories :: PGF -> JSValue
doCategories pgf = showJSON $ map toJSObject
      [[("cat",cat)] | cat <- PGF.categories pgf]


-- * PGF utilities

parse' :: PGF -> String -> Maybe PGF.Category -> Maybe PGF.Language -> [(PGF.Language,[PGF.Tree])]
parse' pgf input mcat mfrom = 
   [(from,ts) | from <- froms, PGF.canParse pgf from, let ts = PGF.parse pgf from cat input, not (null ts)]
  where froms = maybe (PGF.languages pgf) (:[]) mfrom
        cat = fromMaybe (PGF.startCat pgf) mcat

complete' :: PGF -> String -> Maybe PGF.Category -> Maybe PGF.Language -> [(PGF.Language,[String])]
complete' pgf input mcat mfrom = 
   [(from,ss) | from <- froms, PGF.canParse pgf from, let ss = complete pgf from cat input, not (null ss)]
  where froms = maybe (PGF.languages pgf) (:[]) mfrom
        cat = fromMaybe (PGF.startCat pgf) mcat

complete :: PGF -> PGF.Language -> PGF.Category -> String -> [String]
complete pgf from cat input = 
         let ws = words input
             prefix = "" -- FIXME
             state0 = PGF.initState pgf from cat
             state = foldl PGF.nextState state0 ws
             compls = PGF.getCompletions state prefix
          in Map.keys compls

linearize' :: PGF -> Maybe PGF.Language -> PGF.Tree -> [(PGF.Language,String)]
linearize' pgf mto tree = 
    case mto of
      Nothing -> PGF.linearizeAllLang pgf tree
      Just to -> [(to,PGF.linearize pgf to tree)]

-- * General CGI and JSON stuff

outputJSON :: JSON a => a -> CGI CGIResult
outputJSON x = do setHeader "Content-Type" "text/json; charset=utf-8"
                  outputStrict $ UTF8.encodeString $ encode x

outputStrict :: String -> CGI CGIResult
outputStrict x | x == x = output x
               | otherwise = fail "I am the pope."