Merge remote-tracking branch 'origin/master' into basque

src/runtime/c/pgf/expr.c

@@ -1650,10 +1650,10 @@ pgf_print_hypo(PgfHypo *hypo, PgfPrintContext* ctxt, int prec,
         } else {
             pgf_print_type(hypo->type, ctxt, prec, out, err);
         }
-        
+
         gu_pool_free(tmp_pool);
     }
-    
+
 	PgfPrintContext* new_ctxt = malloc(sizeof(PgfPrintContext));
 	new_ctxt->name = hypo->cid;
 	new_ctxt->next = ctxt;
@@ -1668,7 +1668,7 @@ pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec,
     
     if (n_hypos > 0) {
 		if (prec > 0) gu_putc('(', out, err);
-		
+
 		PgfPrintContext* new_ctxt = ctxt;
 		for (size_t i = 0; i < n_hypos; i++) {
 			PgfHypo *hypo = gu_seq_index(type->hypos, PgfHypo, i);
@@ -1707,6 +1707,22 @@ pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec,
 	}
 }
 
+PGF_API void
+pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt,
+                  GuOut *out, GuExn *err)
+{
+	PgfPrintContext* new_ctxt = ctxt;
+
+    size_t n_hypos = gu_seq_length(hypos);
+	for (size_t i = 0; i < n_hypos; i++) {
+		if (i > 0)
+			gu_putc(' ', out, err);
+
+		PgfHypo *hypo = gu_seq_index(hypos, PgfHypo, i);
+		new_ctxt = pgf_print_hypo(hypo, new_ctxt, 4, out, err);		
+	}
+}
+
 PGF_API void
 pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
                      GuOut* out, GuExn* err)
@@ -1720,30 +1736,6 @@ pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
 	gu_putc('>', out, err);
 }
 
-PGF_API_DECL void
-pgf_print_category(PgfPGF *gr, PgfCId catname,
-                   GuOut* out, GuExn *err)
-{
-	PgfAbsCat* abscat =
-		gu_seq_binsearch(gr->abstract.cats, pgf_abscat_order, PgfAbsCat, catname);
-	if (abscat == NULL) {
-		GuExnData* exn = gu_raise(err, PgfExn);
-		exn->data = "Unknown category";
-		return;
-	}
-
-	gu_puts(abscat->name, out, err);
-
-	PgfPrintContext* ctxt = NULL;
-	size_t n_hypos = gu_seq_length(abscat->context);
-	for (size_t i = 0; i < n_hypos; i++) {
-		PgfHypo *hypo = gu_seq_index(abscat->context, PgfHypo, i);
-
-		gu_putc(' ', out, err);
-		ctxt = pgf_print_hypo(hypo, ctxt, 4, out, err);
-	}
-}
-
 PGF_API bool
 pgf_type_eq(PgfType* t1, PgfType* t2)
 {

src/runtime/c/pgf/expr.h

@@ -234,15 +234,15 @@ PGF_API_DECL void
 pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec,
                GuOut* out, GuExn *err);
 
+PGF_API_DECL void
+pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt,
+                  GuOut *out, GuExn *err);
+
 PGF_API_DECL void
 pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
                      GuOut* out, GuExn* err);
 
-PGF_API_DECL void
+PGF_API_DECL prob_t
-pgf_print_category(PgfPGF *gr, PgfCId catname,
-                   GuOut* out, GuExn *err);
-
-PGF_API prob_t
 pgf_compute_tree_probability(PgfPGF *gr, PgfExpr expr);
 
 #endif /* EXPR_H_ */

src/runtime/c/pgf/pgf.c

@@ -140,6 +140,29 @@ pgf_start_cat(PgfPGF* pgf, GuPool* pool)
 	return type;
 }
 
+PGF_API PgfHypos*
+pgf_category_context(PgfPGF *gr, PgfCId catname)
+{
+	PgfAbsCat* abscat =
+		gu_seq_binsearch(gr->abstract.cats, pgf_abscat_order, PgfAbsCat, catname);
+	if (abscat == NULL) {
+		return NULL;
+	}
+
+	return abscat->context;
+}
+
+PGF_API prob_t
+pgf_category_prob(PgfPGF* pgf, PgfCId catname)
+{
+	PgfAbsCat* abscat =
+		gu_seq_binsearch(pgf->abstract.cats, pgf_abscat_order, PgfAbsCat, catname);
+	if (abscat == NULL)
+		return INFINITY;
+
+	return abscat->prob;
+}
+
 PGF_API GuString
 pgf_language_code(PgfConcr* concr)
 {
@@ -173,7 +196,7 @@ pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err)
 }
 
 PGF_API void
-pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, 
+pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname,
                           GuMapItor* itor, GuExn* err) 
 {
 	size_t n_funs = gu_seq_length(pgf->abstract.funs);
@@ -199,7 +222,17 @@ pgf_function_type(PgfPGF* pgf, PgfCId funname)
 	return absfun->type;
 }
 
-PGF_API double
+PGF_API_DECL bool
+pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname)
+{
+	PgfAbsFun* absfun =
+		gu_seq_binsearch(pgf->abstract.funs, pgf_absfun_order, PgfAbsFun, funname);
+	if (absfun == NULL)
+		return false;
+	return (absfun->defns == NULL);
+}
+
+PGF_API prob_t
 pgf_function_prob(PgfPGF* pgf, PgfCId funname) 
 {
 	PgfAbsFun* absfun =

src/runtime/c/pgf/pgf.h

@@ -81,6 +81,12 @@ pgf_iter_categories(PgfPGF* pgf, GuMapItor* itor, GuExn* err);
 PGF_API_DECL PgfType*
 pgf_start_cat(PgfPGF* pgf, GuPool* pool);
 
+PGF_API_DECL PgfHypos*
+pgf_category_context(PgfPGF *gr, PgfCId catname);
+
+PGF_API_DECL prob_t
+pgf_category_prob(PgfPGF* pgf, PgfCId catname);
+
 PGF_API_DECL void
 pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err);
 
@@ -91,7 +97,10 @@ pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname,
 PGF_API_DECL PgfType*
 pgf_function_type(PgfPGF* pgf, PgfCId funname);
 
-PGF_API_DECL double
+PGF_API_DECL bool
+pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname);
+
+PGF_API_DECL prob_t
 pgf_function_prob(PgfPGF* pgf, PgfCId funname);
 
 PGF_API_DECL GuString

src/runtime/haskell-bind/PGF2.hsc

@@ -27,9 +27,10 @@ module PGF2 (-- * PGF
              -- * Abstract syntax
              AbsName,abstractName,
              -- ** Categories
-             Cat,categories,showCategory,
+             Cat,categories,categoryContext,
              -- ** Functions
-             Fun,functions, functionsByCat, functionType, hasLinearization,
+             Fun, functions, functionsByCat,
+             functionType, functionIsConstructor, hasLinearization,
              -- ** Expressions
              Expr,showExpr,readExpr,pExpr,
              mkAbs,unAbs,
@@ -44,7 +45,7 @@ module PGF2 (-- * PGF
 
              -- ** Types
              Type, Hypo, BindType(..), startCat,
-             readType, showType,
+             readType, showType, showContext,
              mkType, unType,
 
              -- ** Type checking
@@ -240,6 +241,16 @@ functionType p fn =
               then Nothing
               else Just (Type c_type (touchPGF p)))
 
+-- | The type of a function
+functionIsConstructor :: PGF -> Fun -> Bool
+functionIsConstructor p fn =
+  unsafePerformIO $
+  withGuPool $ \tmpPl -> do
+    c_fn <- newUtf8CString fn tmpPl
+    res <- pgf_function_is_constructor (pgf p) c_fn
+    touchPGF p
+    return (res /= 0)
+
 -- | Checks an expression against a specified type.
 checkExpr :: PGF -> Expr -> Type -> Either String Expr
 checkExpr (PGF p _) (Expr c_expr touch1) (Type c_ty touch2) =
@@ -1068,25 +1079,38 @@ categories p =
       name  <- peekUtf8CString (castPtr key)
       writeIORef ref $! (name : names)
 
-showCategory :: PGF -> Cat -> String
+categoryContext :: PGF -> Cat -> [Hypo]
-showCategory p cat =
+categoryContext p cat =
   unsafePerformIO $
     withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
+      do c_cat <- newUtf8CString cat tmpPl
-         exn <- gu_new_exn tmpPl
+         c_hypos <- pgf_category_context (pgf p) c_cat
-         c_cat <- newUtf8CString cat tmpPl
+         if c_hypos == nullPtr
-         pgf_print_category (pgf p) c_cat out exn
+           then return []
+           else do n_hypos <- (#peek GuSeq, len) c_hypos
+                   peekHypos (c_hypos `plusPtr` (#offset GuSeq, data)) 0 n_hypos
+  where
+    peekHypos :: Ptr a -> Int -> Int -> IO [Hypo]
+    peekHypos c_hypo i n
+      | i < n     = do cid <- (#peek PgfHypo, cid) c_hypo >>= peekUtf8CString
+                       c_ty <- (#peek PgfHypo, type) c_hypo
+                       bt  <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo)
+                       hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n
+                       return ((bt,cid,Type c_ty (touchPGF p)) : hs)
+      | otherwise = return []
+
+    toBindType :: CInt -> BindType
+    toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
+    toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit
+
+categoryProb :: PGF -> Cat -> Float
+categoryProb p cat =
+  unsafePerformIO $
+    withGuPool $ \tmpPl ->
+      do c_cat <- newUtf8CString cat tmpPl
+         c_prob <- pgf_category_prob (pgf p) c_cat
          touchPGF p
-         failed <- gu_exn_is_raised exn
+         return (realToFrac c_prob)
-         if failed
-           then do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
-                   if is_exn
-                     then do c_msg <- (#peek GuExn, data.data) exn
-                             msg <- peekUtf8CString c_msg
-                             throwIO (PGFError msg)
-                     else throwIO (PGFError "The abstract tree cannot be linearized")
-           else do s <- gu_string_buf_freeze sb tmpPl
-                   peekUtf8CString s
 
 -----------------------------------------------------------------------------
 -- Helper functions

src/runtime/haskell-bind/PGF2/FFI.hsc

@@ -295,6 +295,12 @@ foreign import ccall "pgf/pgf.h pgf_iter_categories"
 foreign import ccall "pgf/pgf.h pgf_start_cat"
   pgf_start_cat :: Ptr PgfPGF -> Ptr GuPool -> IO PgfType
 
+foreign import ccall "pgf/pgf.h pgf_category_context"
+  pgf_category_context :: Ptr PgfPGF -> CString -> IO (Ptr GuSeq)
+
+foreign import ccall "pgf/pgf.h pgf_category_prob"
+  pgf_category_prob :: Ptr PgfPGF -> CString -> IO (#type prob_t)
+
 foreign import ccall "pgf/pgf.h pgf_iter_functions"
   pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
 
@@ -304,6 +310,9 @@ foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat"
 foreign import ccall "pgf/pgf.h pgf_function_type"
    pgf_function_type :: Ptr PgfPGF -> CString -> IO PgfType
 
+foreign import ccall "pgf/expr.h pgf_function_is_constructor"
+   pgf_function_is_constructor :: Ptr PgfPGF -> CString -> IO (#type bool)
+
 foreign import ccall "pgf/pgf.h pgf_print_name"
   pgf_print_name :: Ptr PgfConcr -> CString -> IO CString
 
@@ -476,12 +485,12 @@ foreign import ccall "pgf/expr.h pgf_print_expr"
 foreign import ccall "pgf/expr.h pgf_print_expr_tuple"
   pgf_print_expr_tuple :: CSizeT -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO ()
 
-foreign import ccall "pgf/expr.h pgf_print_category"
-  pgf_print_category :: Ptr PgfPGF -> CString -> Ptr GuOut -> Ptr GuExn -> IO ()
-
 foreign import ccall "pgf/expr.h pgf_print_type"
   pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
 
+foreign import ccall "pgf/expr.h pgf_print_context"
+  pgf_print_context :: Ptr GuSeq -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO ()
+
 foreign import ccall "pgf/pgf.h pgf_generate_all"
   pgf_generate_all :: Ptr PgfPGF -> PgfType -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
 

src/runtime/haskell-bind/PGF2/Type.hsc

@@ -64,8 +64,7 @@ mkType hypos cat exprs = unsafePerformIO $ do
   typPl  <- gu_new_pool
   let n_exprs = fromIntegral (length exprs) :: CSizeT
   c_type <- gu_malloc typPl ((#size PgfType) + n_exprs * (#size PgfExpr))
-  c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) typPl
+  c_hypos <- newSequence (#size PgfHypo) (pokeHypo typPl) hypos typPl
-  hs <- pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos typPl
   (#poke PgfType, hypos) c_type c_hypos
   ccat <- newUtf8CString cat typPl
   (#poke PgfType, cid) c_type ccat
@@ -73,27 +72,25 @@ mkType hypos cat exprs = unsafePerformIO $ do
   pokeExprs (c_type `plusPtr` (#offset PgfType, exprs)) exprs
   typFPl <- newForeignPtr gu_pool_finalizer typPl
   return (Type c_type (mapM_ touchHypo hypos >> mapM_ touchExpr exprs >> touchForeignPtr typFPl))
+
+pokeHypo :: Ptr GuPool -> Ptr a -> Hypo -> IO ()
+pokeHypo pool c_hypo (bind_type,cid,Type c_ty _) = do
+  (#poke PgfHypo, bind_type) c_hypo cbind_type
+  newUtf8CString cid pool >>= (#poke PgfHypo, cid) c_hypo
+  (#poke PgfHypo, type) c_hypo c_ty
   where
-    pokeHypos :: Ptr a -> [Hypo] -> Ptr GuPool -> IO ()
+    cbind_type :: CInt
-    pokeHypos c_hypo []                                    typPl = return ()
+    cbind_type =
-    pokeHypos c_hypo ((bind_type,cid,Type c_ty _) : hypos) typPl = do
+      case bind_type of
-      (#poke PgfHypo, bind_type) c_hypo cbind_type
+        Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
-      newUtf8CString cid typPl >>= (#poke PgfHypo, cid) c_hypo
+        Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
-      (#poke PgfHypo, type) c_hypo c_ty
-      pokeHypos (plusPtr c_hypo (#size PgfHypo)) hypos typPl
-      where
-        cbind_type :: CInt
-        cbind_type =
-          case bind_type of
-            Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
-            Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
 
-    pokeExprs ptr []              = return ()
+pokeExprs ptr []              = return ()
-    pokeExprs ptr ((Expr e _):es) = do
+pokeExprs ptr ((Expr e _):es) = do
-      poke ptr e
+  poke ptr e
-      pokeExprs (plusPtr ptr (#size PgfExpr)) es
+  pokeExprs (plusPtr ptr (#size PgfExpr)) es
-
+    
-    touchHypo (_,_,ty) = touchType ty
+touchHypo (_,_,ty) = touchType ty
 
 -- | Decomposes a type into a list of hypothesises, a category and 
 -- a list of arguments for the category.
@@ -125,3 +122,20 @@ unType (Type c_type touch) = unsafePerformIO $ do
                        es <- peekExprs ptr (i+1) n
                        return (Expr e touch : es)
       | otherwise = return []
+
+-- | renders a type as a 'String'. The list
+-- of identifiers is the list of all free variables
+-- in the type in order reverse to the order
+-- of binding.
+showContext :: [CId] -> [Hypo] -> String
+showContext scope hypos =
+  unsafePerformIO $
+    withGuPool $ \tmpPl ->
+      do (sb,out) <- newOut tmpPl
+         c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl
+         printCtxt <- newPrintCtxt scope tmpPl
+         exn <- gu_new_exn tmpPl
+         pgf_print_context c_hypos printCtxt out exn
+         mapM_ touchHypo hypos
+         s <- gu_string_buf_freeze sb tmpPl
+         peekUtf8CString s

src/runtime/java/jpgf.c

@@ -188,7 +188,7 @@ Java_org_grammaticalframework_pgf_PGF_getFunctionProb(JNIEnv* env, jobject self,
 	PgfPGF* pgf = get_ref(env, self);
 	GuPool* tmp_pool = gu_local_pool();
 	PgfCId id = j2gu_string(env, jid, tmp_pool);
-	double prob = pgf_function_prob(pgf, id);
+	prob_t prob = pgf_function_prob(pgf, id);
 	gu_pool_free(tmp_pool);
 
 	return prob;