PGF service & minibar: put a limit on the number of parse trees

+ In the PGF web service API, the commands parse, translate and translategroup
  now accept a limit parameter. It limits the number of parse trees returned.
  If no limit is given, the behaviour is backwards compatible, i.e. no limit
  is applied.
+ In minibar, the limit is now set to 25 by default.

This change is based on a suggestion by Kaarel Kaljurand.

3 files changed, 20 insertions, 16 deletions

diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index 7bd1c11e4..bc283bf24 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -56,14 +56,14 @@ cgiMain' cache path =
 pgfMain :: PGF -> String -> CGI CGIResult
 pgfMain pgf command =
     case command of
-      "parse"          -> outputJSONP =<< doParse pgf `fmap` getText `ap` getCat `ap` getFrom
+      "parse"          -> outputJSONP =<< doParse pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getLimit
       "complete"       -> outputJSONP =<< doComplete pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getLimit
       "linearize"      -> outputJSONP =<< doLinearize pgf `fmap` getTree `ap` getTo
       "linearizeAll"   -> outputJSONP =<< doLinearizes pgf `fmap` getTree `ap` getTo
       "random"         -> getCat >>= \c -> getDepth >>= \dp -> getLimit >>= \l -> getTo >>= \to -> liftIO (doRandom pgf c dp l to) >>= outputJSONP
       "generate"       -> outputJSONP =<< doGenerate pgf `fmap` getCat `ap` getDepth `ap` getLimit `ap` getTo
-      "translate"      -> outputJSONP =<< doTranslate pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo
-      "translategroup" -> outputJSONP =<< doTranslateGroup pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo
+      "translate"      -> outputJSONP =<< doTranslate pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo `ap` getLimit
+      "translategroup" -> outputJSONP =<< doTranslateGroup pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo `ap` getLimit
       "grammar"        -> outputJSONP =<< doGrammar pgf `fmap` requestAcceptLanguage
       "abstrtree"      -> outputGraphviz . abstrTree pgf =<< getTree
       "alignment"      -> outputGraphviz . alignment pgf =<< getTree
@@ -159,8 +159,8 @@ doExternal (Just cmd) input =
          liftIO $ removeFile tmpfile2
          return r
 
-doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> JSValue
-doTranslate pgf input mcat mfrom mto =
+doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> Maybe Int -> JSValue
+doTranslate pgf input mcat mfrom mto mlimit =
   showJSON
      [makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po)
           | (from,po,bs) <- parse' pgf input mcat mfrom]
@@ -173,7 +173,7 @@ doTranslate pgf input mcat mfrom mto =
                         "linearizations".=
                             [makeObj ["to".=to, "text".=text, "brackets".=bs]
                                | (to,text,bs)<- linearizeAndBind pgf mto tree]]
-                | tree <- trees]]
+                | tree <- maybe id take mlimit trees]]
         PGF.ParseIncomplete -> ["incomplete".=True]
         PGF.ParseFailed n   -> ["parseFailed".=n]
         PGF.TypeError errs -> jsonTypeErrors errs
@@ -183,8 +183,8 @@ jsonTypeErrors errs =
                        | (fid,err) <- errs]]
 
 -- used in phrasebook
-doTranslateGroup :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> JSValue
-doTranslateGroup pgf input mcat mfrom mto =
+doTranslateGroup :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> Maybe Int -> JSValue
+doTranslateGroup pgf input mcat mfrom mto mlimit =
   showJSON
     [makeObj ["from".=langOnly (PGF.showLanguage from),
               "to".=langOnly (PGF.showLanguage to),
@@ -194,7 +194,7 @@ doTranslateGroup pgf input mcat mfrom mto =
               ]
        | 
          (from,po,bs) <- parse' pgf input mcat mfrom,
-         (to,output)  <- groupResults [(t, linearize' pgf mto t) | t <- case po of {PGF.ParseOk ts -> ts; _ -> []}]
+         (to,output)  <- groupResults [(t, linearize' pgf mto t) | t <- case po of {PGF.ParseOk ts -> maybe id take mlimit ts; _ -> []}]
           ]
   where
    groupResults = Map.toList . foldr more Map.empty . start . collect
@@ -240,14 +240,14 @@ doTranslateGroup pgf input mcat mfrom mto =
 
    notDisamb = (/="Disamb") . take 6 . PGF.showLanguage
 
-doParse :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> JSValue
-doParse pgf input mcat mfrom = showJSON $ map makeObj
+doParse :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> JSValue
+doParse pgf input mcat mfrom mlimit = showJSON $ map makeObj
      ["from".=from : "brackets".=bs : jsonParseOutput po
         | (from,po,bs) <- parse' pgf input mcat mfrom]
   where
     jsonParseOutput output =
       case output of
-        PGF.ParseOk trees   -> ["trees".=trees]
+        PGF.ParseOk trees   -> ["trees".=maybe id take mlimit trees]
         PGF.TypeError errs  -> jsonTypeErrors errs
         PGF.ParseIncomplete -> ["incomlete".=True]
         PGF.ParseFailed n   -> ["parseFailed".=n]
diff --git a/src/www/minibar/minibar-api.html b/src/www/minibar/minibar-api.html
index a30fa2e5d..d65d92652 100644
--- a/src/www/minibar/minibar-api.html
+++ b/src/www/minibar/minibar-api.html
@@ -70,12 +70,14 @@ For an example, see <a href="minibar.html">minibar.html</a>.
   can be set to override various default options:
     <table class=border>
         <tr><th>Option<th>Default<th>Description
-        <tr><td>show_abstract<td>false<td rowspan=5>See Translations,
+        <tr><td>show_abstract<td>false<td rowspan=6>See Translations,
 	  not used directly by Minibar
 	<tr><td>show_trees<td>false
 	<tr><td>tree_img_format<td>"png"
 	<tr><td>show_grouped_translations<td>true
 	<tr><td>show_brackets<td>false
+	<tr><td>translate_limit<td>25
+
 	<tr><td>delete_button_text<td>"⌫"<td rowspan=5>See Input,
 	  not used directly by Minibar
 	<tr><td>default_source_language<td>null
@@ -212,7 +214,7 @@ HTML file, you would normally include at least the following:
 	<tr><td>show_grouped_translations<td>true<td>in case there are
 	  multiple translations, group them by concrete language
 	<tr><td>show_brackets<td>false<td>show bracketed string
-    </table>
+	<tr><td>translate_limit<td>25<td>maximum number of parse trees to retrieve    </table>
 
 </ul>
 
@@ -247,7 +249,7 @@ the user interface:
 <hr>
 <div class=modtime>
 <small class=modtime>
-HTML <!-- hhmts start -->Last modified: Mon Sep 17 17:52:22 CEST 2012 <!-- hhmts end -->
+HTML <!-- hhmts start -->Last modified: Sun Sep 30 17:33:51 CEST 2012 <!-- hhmts end -->
 </small>
 </div>
 
diff --git a/src/www/minibar/minibar_translations.js b/src/www/minibar/minibar_translations.js
index 167417844..43b959d3e 100644
--- a/src/www/minibar/minibar_translations.js
+++ b/src/www/minibar/minibar_translations.js
@@ -14,7 +14,8 @@ function Translations(server,opts) {
 	tree_img_format: "png", // format for trees & alignment images,
 	                        // can be "gif", "png" or "svg"
 	show_grouped_translations: true,
-	show_brackets: false // show bracketed string
+	show_brackets: false, // show bracketed string
+	translate_limit: 25 // maximum number of parse trees to retrieve
     }
 
     // Apply supplied options
@@ -53,6 +54,7 @@ Translations.prototype.get_translations=function() {
     with(this) {
 	var c=current;
 	var args={from:c.from,input:gf_unlex(c.input),cat:startcat}
+	if(options.translate_limit) args.limit=options.translate_limit
 	if(options.show_grouped_translations)
 	    server.translategroup(args,bind(show_groupedtranslations,this));
 	else