Merge remote-tracking branch 'origin/master' into pgf2-hackage

5 files changed, 69 insertions, 21 deletions

diff --git a/src/runtime/c/pgf/parser.c b/src/runtime/c/pgf/parser.c
index c3255154d..1ee24ac59 100644
--- a/src/runtime/c/pgf/parser.c
+++ b/src/runtime/c/pgf/parser.c
@@ -2301,26 +2301,29 @@ pgf_get_parse_roots(PgfParsing* ps, GuPool* pool)
 PGF_API GuSeq*
 pgf_ccat_to_range(PgfParsing* ps, PgfCCat* ccat, GuPool* pool)
 {
-	PgfItemConts*  conts = ccat->conts;
 	PgfParseState* state = ps->before;
 	GuBuf* buf = gu_new_buf(PgfParseRange, pool);
 
-	while (conts != NULL) {
-		PgfParseRange* range = gu_buf_extend(buf);
-		range->start = conts->state->end_offset;
-		range->end   = conts->state->end_offset;
-		range->field = conts->ccat->cnccat->labels[conts->lin_idx];
-		
+	while (ccat->conts != NULL) {
+		size_t start = ccat->conts->state->end_offset;
+		size_t end   = start;
 		while (state != NULL) {
-			if (pgf_parsing_get_completed(state, conts) == ccat) {
-				if (state->start_offset >= range->start)
-					range->end = state->start_offset;
+			if (pgf_parsing_get_completed(state, ccat->conts) == ccat) {
+				if (state->start_offset >= start)
+					end = state->start_offset;
 				break;
 			}
 			state = state->next;
 		}
 
-		conts = conts->ccat->conts;
+		if (start != end) {
+			PgfParseRange* range = gu_buf_extend(buf);
+			range->start = start;
+			range->end   = end;
+			range->field = ccat->cnccat->labels[ccat->conts->lin_idx];
+		}
+
+		ccat = ccat->conts->ccat;
 	}
 
 	return gu_buf_data_seq(buf);
diff --git a/src/runtime/c/pgf/scanner.c b/src/runtime/c/pgf/scanner.c
index ad78233ea..7a91b5c7c 100644
--- a/src/runtime/c/pgf/scanner.c
+++ b/src/runtime/c/pgf/scanner.c
@@ -115,7 +115,8 @@ pgf_morpho_iter(PgfProductionIdx* idx,
 		PgfCId lemma = entry->papp->fun->absfun->name;
 		GuString analysis = entry->ccat->cnccat->labels[entry->lin_idx];
 
-		prob_t prob = entry->papp->fun->absfun->ep.prob;
+		prob_t prob = entry->ccat->cnccat->abscat->prob +
+		              entry->papp->fun->absfun->ep.prob;
 		callback->callback(callback,
 						   lemma, analysis, prob, err);
 		if (!gu_ok(err))
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 4b41a7471..827e19bf4 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -726,7 +726,7 @@ parseToChart :: Concr      -- ^ the language with which we parse
                            -- If a literal has been recognized then the output should
                            -- be Just (expr,probability,end_offset)
              -> Int        -- ^ the maximal number of roots
-             -> ParseOutput ([FId],Map.Map FId ([(Int,Int,String)],[(Expr,[PArg],Float)]))
+             -> ParseOutput ([FId],Map.Map FId ([(Int,Int,String)],[(Expr,[PArg],Float)],Cat))
 parseToChart lang (Type ctype touchType) sent heuristic callbacks roots =
   unsafePerformIO $
   withGuPool $ \parsePl -> do
@@ -776,19 +776,23 @@ parseToChart lang (Type ctype touchType) sent heuristic callbacks roots =
       c_total_cats <- (#peek PgfConcr, total_cats) (concr lang)
       if Map.member fid chart || fid < c_total_cats
         then return (fid,chart)
-        else do range <- get_range c_ccat >>= peekSequence peekRange (#size PgfParseRange)
+        else do c_cnccat <- (#peek PgfCCat, cnccat) c_ccat
+                c_abscat <- (#peek PgfCCat, cnccat) c_cnccat
+                c_name   <- (#peek PgfCCat, cnccat) c_abscat
+                cat      <- peekUtf8CString c_name
+                range <- get_range c_ccat >>= peekSequence peekRange (#size PgfParseRange)
                 c_prods <- (#peek PgfCCat, prods) c_ccat
                 if c_prods == nullPtr
-                  then do return (fid,Map.insert fid (range,[]) chart)
+                  then do return (fid,Map.insert fid (range,[],cat) chart)
                   else do c_len <- (#peek PgfCCat, n_synprods) c_ccat
-                          (prods,chart) <- fixIO (\res -> peekProductions (Map.insert fid (range,fst res) chart)
+                          (prods,chart) <- fixIO (\res -> peekProductions (Map.insert fid (range,fst res,cat) chart)
                                                                           (fromIntegral (c_len :: CSizeT))
                                                                           (c_prods `plusPtr` (#offset GuSeq, data)))
                           return (fid,chart)
       where
         peekProductions chart 0   ptr = return ([],chart)
         peekProductions chart len ptr = do
-          (ps1, chart) <- deRef (peekProduction chart) ptr
+          (ps1,chart) <- deRef (peekProduction chart) ptr
           (ps2,chart) <- peekProductions chart (len-1) (ptr `plusPtr` (#size GuVariant))
           return (ps1++ps2,chart)
 
@@ -806,13 +810,15 @@ parseToChart lang (Type ctype touchType) sent heuristic callbacks roots =
                                                    return ([(Expr expr (touchConcr lang), pargs, p)],chart) }
             (#const PGF_PRODUCTION_COERCE) -> do { c_coerce    <- (#peek PgfProductionCoerce, coerce) dt ;
                                                    (fid,chart) <- peekCCat get_range chart c_coerce ;
-                                                   return (maybe [] snd (Map.lookup fid chart),chart) }
+                                                   return (maybe [] snd3 (Map.lookup fid chart),chart) }
             (#const PGF_PRODUCTION_EXTERN) -> do { c_ep     <- (#peek PgfProductionExtern, ep) dt ;
                                                    expr     <- (#peek PgfExprProb, expr) c_ep ;
                                                    p        <- (#peek PgfExprProb, prob) c_ep ;
                                                    return ([(Expr expr (touchConcr lang), [], p)],chart) }
             _                             -> error ("Unknown production type "++show tag++" in the grammar")
 
+        snd3 (_,x,_) = x
+
         peekPArgs chart 0   ptr = return ([],chart)
         peekPArgs chart len ptr = do
           (a, chart) <- peekPArg  chart ptr
diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index 5817be7f0..e30ff8652 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -152,6 +152,8 @@ cpgfMain qsem command (t,(pgf,pc)) =
   case command of
     "c-parse"       -> withQSem qsem $
                        out t=<< join (parse # input % start % limit % treeopts)
+    "c-parseToChart"-> withQSem qsem $
+                       out t=<< join (parseToChart # input % limit)
     "c-linearize"   -> out t=<< lin # tree % to
     "c-bracketedLinearize"
                     -> out t=<< bracketedLin # tree % to
@@ -218,6 +220,35 @@ cpgfMain qsem command (t,(pgf,pc)) =
             purge r@(_,t') = if diffUTCTime t t'<120 then Just r else Nothing
                              -- remove unused parse results after 2 minutes
 -}
+
+    parseToChart ((from,concr),input) mlimit =
+      do r <- case C.parseToChart concr cat input (-1) callbacks (fromMaybe 5 mlimit) of
+                C.ParseOk chart     -> return (good chart)
+                C.ParseFailed _ tok -> return (bad tok)
+                C.ParseIncomplete   -> return (bad "")
+         return $ showJSON [makeObj ("from".=from:r)]
+      where
+        callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks
+        cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs]
+
+        bad  err           = ["parseFailed".=err]
+        good (roots,chart) = ["roots".=showJSON roots,
+                              "chart".=makeObj [show fid .= mkChartObj inf | (fid,inf)<-Map.toList chart]]
+
+        mkChartObj (brackets,prods,cat) =
+          makeObj ["brackets".=map mkChartBracket brackets
+                  ,"prods"   .=map mkChartProd prods
+                  ,"cat"     .=cat
+                  ]
+
+        mkChartBracket (s,e,ann) =
+          makeObj ["start".=s,"end".=e,"ann".=ann]
+
+        mkChartProd (expr,args,prob) =
+          makeObj ["tree".=expr,"args".=map mkChartPArg args,"prob".=prob]
+
+        mkChartPArg (C.PArg _ fid) = showJSON fid
+
     linAll tree to = showJSON (linAll' tree to)
     linAll' tree (tos,unlex) =
         [makeObj ["to".=to,
diff --git a/src/www/js/support.js b/src/www/js/support.js
index 2c7dd782e..e999f8298 100644
--- a/src/www/js/support.js
+++ b/src/www/js/support.js
@@ -89,7 +89,7 @@ function GetXmlHttpObject(handler)
   return objXMLHttp
 }
 
-function ajax_http(method,url,body,callback,errorcallback) {
+function ajax_http(method,url,body,contenttype,callback,errorcallback) {
     var http=GetXmlHttpObject()
     if (!http) {
 	var errortext="Browser does not support HTTP Request";
@@ -109,17 +109,20 @@ function ajax_http(method,url,body,callback,errorcallback) {
 	}
 	http.onreadystatechange=statechange;
 	http.open(method,url,true)
+	if (contenttype != null) {
+		http.setRequestHeader("Content-Type", contenttype)
+	}
 	http.send(body)
     }
     return http
 }
 
 function ajax_http_get(url,callback,errorcallback) {
-    ajax_http("GET",url,null,callback,errorcallback)
+    ajax_http("GET",url,null,null,callback,errorcallback)
 }
 
 function ajax_http_post(url,formdata,callback,errorcallback) {
-    ajax_http("POST",url,formdata,callback,errorcallback)
+    ajax_http("POST",url,formdata,null,callback,errorcallback)
     // See https://developer.mozilla.org/En/XMLHttpRequest/Using_XMLHttpRequest#Using_FormData_objects
 }
 
@@ -132,6 +135,10 @@ function ajax_http_post_json(url,formdata,cont,errorcallback) {
     ajax_http_post(url, formdata, with_json(cont,errorcallback), errorcallback);
 }
 
+function ajax_http_post_querystring_json(url,querystring,cont,errorcallback) {
+    ajax_http("POST",url,querystring,"application/x-www-form-urlencoded",with_json(cont,errorcallback),errorcallback);
+}
+
 function with_json(cont,errorcallback) {
     return function(txt){
 	if(txt) {