GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-14 13:42:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

Added /random to pgf-server.

Browse Source
This commit is contained in:
bjorn
2008-11-04 09:09:22 +00:00
parent 3a6466ac1a
commit 748c695009
1 changed files with 14 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
src/server/PGFService.hs
View File

@@ -47,6 +47,7 @@ pgfMain pgf command =
"parse" -> return (doParse pgf) `ap` getText `ap` getCat `ap` getFrom "parse" -> return (doParse pgf) `ap` getText `ap` getCat `ap` getFrom
"complete" -> return (doComplete pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getLimit "complete" -> return (doComplete pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getLimit
"linearize" -> return (doLinearize pgf) `ap` getTree `ap` getTo "linearize" -> return (doLinearize pgf) `ap` getTree `ap` getTo
"random" -> getCat >>= \c -> getLimit >>= liftIO . doRandom pgf c
"translate" -> return (doTranslate pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo "translate" -> return (doTranslate pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo
"grammar" -> return (doGrammar pgf) `ap` requestAcceptLanguage "grammar" -> return (doGrammar pgf) `ap` requestAcceptLanguage
_ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command] _ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command]
@@ -122,6 +123,13 @@ doLinearize :: PGF -> PGF.Tree -> Maybe PGF.Language -> JSValue
doLinearize pgf tree mto = showJSON $ map toJSObject doLinearize pgf tree mto = showJSON $ map toJSObject
[[("to", PGF.showLanguage to),("text",text)] | (to,text) <- linearize' pgf mto tree] [[("to", PGF.showLanguage to),("text",text)] | (to,text) <- linearize' pgf mto tree]
doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> IO JSValue
doRandom pgf mcat mlimit =
do trees <- random' pgf mcat
return $ showJSON $ map toJSObject [[("tree", PGF.showTree tree)] | tree <- limit trees]
where limit = take (fromMaybe maxLimit mlimit)
maxLimit = 1000
doGrammar :: PGF -> Maybe (Accept Language) -> JSValue doGrammar :: PGF -> Maybe (Accept Language) -> JSValue
doGrammar pgf macc = showJSON $ toJSObject doGrammar pgf macc = showJSON $ toJSObject
[("name", showJSON (PGF.abstractName pgf)), [("name", showJSON (PGF.abstractName pgf)),
@@ -141,6 +149,9 @@ instance JSON PGF.CId where
-- * PGF utilities -- * PGF utilities
cat :: PGF -> Maybe PGF.Type -> PGF.Type
cat pgf mcat = fromMaybe (PGF.startCat pgf) mcat
parse' :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [(PGF.Language,[PGF.Tree])] parse' :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [(PGF.Language,[PGF.Tree])]
parse' pgf input mcat mfrom = parse' pgf input mcat mfrom =
[(from,ts) | from <- froms, PGF.canParse pgf from, let ts = PGF.parse pgf from cat input, not (null ts)] [(from,ts) | from <- froms, PGF.canParse pgf from, let ts = PGF.parse pgf from cat input, not (null ts)]
@@ -160,6 +171,9 @@ linearize' pgf mto tree =
Nothing -> PGF.linearizeAllLang pgf tree Nothing -> PGF.linearizeAllLang pgf tree
Just to -> [(to,PGF.linearize pgf to tree)] Just to -> [(to,PGF.linearize pgf to tree)]
random' :: PGF -> Maybe PGF.Type -> IO [PGF.Tree]
random' pgf mcat = PGF.generateRandom pgf (fromMaybe (PGF.startCat pgf) mcat)
selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language
selectLanguage pgf macc = case acceptable of selectLanguage pgf macc = case acceptable of
[] -> case PGF.languages pgf of [] -> case PGF.languages pgf of