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

3 files changed, 90 insertions, 43 deletions

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 733e29c74..409283981 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/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
-showCategory p cat =
+categoryContext :: PGF -> Cat -> [Hypo]
+categoryContext p cat =
   unsafePerformIO $
     withGuPool $ \tmpPl ->
-      do (sb,out) <- newOut tmpPl
-         exn <- gu_new_exn tmpPl
-         c_cat <- newUtf8CString cat tmpPl
-         pgf_print_category (pgf p) c_cat out exn
+      do c_cat <- newUtf8CString cat tmpPl
+         c_hypos <- pgf_category_context (pgf p) c_cat
+         if c_hypos == nullPtr
+           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
-         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
+         return (realToFrac c_prob)
 
 -----------------------------------------------------------------------------
 -- Helper functions
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc
index 71e4b488f..c33f1da50 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hsc
+++ b/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)
 
diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell-bind/PGF2/Type.hsc
index 06b137b1f..57e7eeaa9 100644
--- a/src/runtime/haskell-bind/PGF2/Type.hsc
+++ b/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
-  hs <- pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos typPl
+  c_hypos <- newSequence (#size PgfHypo) (pokeHypo typPl) 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))
-  where
-    pokeHypos :: Ptr a -> [Hypo] -> Ptr GuPool -> IO ()
-    pokeHypos c_hypo []                                    typPl = return ()
-    pokeHypos c_hypo ((bind_type,cid,Type c_ty _) : hypos) typPl = do
-      (#poke PgfHypo, bind_type) c_hypo cbind_type
-      newUtf8CString cid typPl >>= (#poke PgfHypo, cid) c_hypo
-      (#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 ((Expr e _):es) = do
-      poke ptr e
-      pokeExprs (plusPtr ptr (#size PgfExpr)) es
+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
+    cbind_type :: CInt
+    cbind_type =
+      case bind_type of
+        Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
+        Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
 
-    touchHypo (_,_,ty) = touchType ty
+pokeExprs ptr []              = return ()
+pokeExprs ptr ((Expr e _):es) = do
+  poke ptr e
+  pokeExprs (plusPtr ptr (#size PgfExpr)) es
+    
+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