ExampleService

module ExampleService(cgiMain,cgiMain',newPGFCache) where
import System.Random(newStdGen)
import System.FilePath((</>),makeRelative)
import Data.Map(fromList)
import Data.Char(isDigit)
import Data.Maybe(fromJust)
import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
import PGF
import GF.Compile.ToAPI
import Network.CGI
import Text.JSON
import CGIUtils
import Cache
import qualified ExampleDemo as E

newPGFCache = newCache readPGF


cgiMain :: Cache PGF -> CGI CGIResult
cgiMain = handleErrors . handleCGIErrors . cgiMain' "." "."

cgiMain' root cwd cache =
  do command <- getInp "command"
     environ <- parseEnviron =<< getInp "state"
     case command of
       "possibilities"    -> doPossibilities environ
       "provide_example"  -> doProvideExample root cwd cache environ
       "abstract_example" -> doAbstractExample cwd cache environ
       "test_function"    -> doTestFunction cwd cache environ
       _ -> throwCGIError 400 ("Unknown command: "++command) []

doPossibilities environ =
  do example_environ <- parseEnviron =<< getInp "example_state"
     outputJSONP (E.getNext environ example_environ)

doProvideExample root cwd cache environ =
  do Just lang <- readInput "lang"
     fun <- getCId "fun"
     parsePGF <- readParsePGF cwd cache
     let adjpath path = root</>makeRelative "/" (makeRelative root cwd</>path)
     pgf <- liftIO . readCache cache . adjpath =<< getInp "grammar"
     gen <- liftIO newStdGen
     let Just (e,s) = E.provideExample gen environ fun parsePGF pgf lang
         res = (showExpr [] e,s)
     liftIO $ logError $ "proveExample ... = "++show res
     outputJSONP res

doAbstractExample cwd cache environ =
  do example <- getInp "input"
     Just params <- readInput "params"
     absstr <- getInp "abstract"
     Just abs <- return $ readExpr absstr
     liftIO $ logError $ "abstract = "++showExpr [] abs
     Just cat <- readInput "cat"
     let t = mkType [] cat []
     parsePGF <- readParsePGF cwd cache
     let lang:_ = languages parsePGF
     ae <- liftIO $ abstractExample parsePGF environ lang t abs example
     outputJSONP (fmap (\(e,_)->(exprToAPI (instExpMeta params e),e)) ae)

abstractExample parsePGF env lang cat abs example =
    E.searchGoodTree env abs (parse parsePGF lang cat example)

doTestFunction cwd cache environ =
  do fun <- getCId "fun"
     parsePGF <- readParsePGF cwd cache
     let lang:_ = languages parsePGF
     Just txt <- return (E.testThis environ fun parsePGF lang)
     outputJSONP txt

getCId :: String -> CGI CId
getCId name = maybe err return =<< fmap readCId (getInp name)
  where err = throwCGIError 400 ("Bad "++name) []

getLimit :: CGI Int
getLimit = maybe err return =<< readInput "limit"
  where err = throwCGIError 400 "Missing/bad limit" []


readParsePGF cwd cache =
    do parsepgf <- getInp "parser"
       liftIO $ readCache cache (cwd</>parsepgf)

parseEnviron s = do state <- liftIO $ readIO s
                    return $ environ state

getInp name = maybe err (return . UTF8.decodeString) =<< getInput name
  where err = throwCGIError 400 ("Missing parameter: "++name) []


instance JSON CId where
    showJSON = showJSON . show
    readJSON = (readResult =<<) . readJSON

instance JSON Expr where
   showJSON = showJSON . showExpr []
   readJSON = (m2r . readExpr =<<) . readJSON

m2r = maybe (Error "read failed") Ok

readResult s = case reads s of
                 (x,r):_ | lex r==[("","")] -> Ok x
                 _ -> Error "read failed"

--------------------------------------------------------------------------------
--            cat  lincat  fun  lin       fun  cat    cat
environ :: ([(CId, CId)],[(CId, Expr)],[((CId, CId), [CId])]) -> E.Environ
environ (lincats,lins0,funs) =
    E.initial (fromList lincats) concmap fs allfs
  where
    concmap = fromList lins
    allfs = map E.mkFuncWithArg funs
    fs = [E.mkFuncWithArg f | f@((fn,_),_)<-funs, fn `elem` cns]
    cns = map fst lins
    lins = filter (not . E.isMeta .snd) lins0


instExpMeta :: [CId] -> Expr -> Expr
instExpMeta ps = fromJust . readExpr . instMeta ps . showExpr []

instMeta :: [CId] -> String -> String
instMeta ps s =
  case break (=='?') s of
    (s1,'?':s2) ->
       case span isDigit s2 of
         (s21@(_:_),s22) -> s1++show (ps!!(read s21-1))++instMeta ps s22
         ("",s22) -> s1++'?':instMeta ps s22
    (_,_) -> s