proper error checking in the C runtime

src/runtime/haskell-bind/PGF2.hsc

@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}
 #include <pgf/pgf.h>
 #include <gu/enum.h>
 #include <gu/exn.h>
@@ -11,6 +11,8 @@ module PGF2 (-- * PGF
              Expr,readExpr,showExpr,unApp,
              -- * Morphology
              MorphoAnalysis, lookupMorpho, fullFormLexicon,
+             -- * Exceptions
+             PGFError(..)
             ) where
 
 import Prelude hiding (fromEnum)
@@ -23,13 +25,13 @@ import Foreign hiding ( Pool, newPool, unsafePerformIO )
 import Foreign.C
 import Foreign.C.String
 import Foreign.Ptr
-import Data.Char
+import Data.Typeable
 import qualified Data.Map as Map
 import qualified Data.ByteString as BS
 import Data.IORef
 
-
+ 
------------------------------------------------------------------------------
+-----------------------------------------------------------------------
 -- Functions that take a PGF.
 -- PGF has many Concrs.
 --
@@ -43,8 +45,19 @@ data Concr = Concr {concr :: Ptr PgfConcr, concrMaster :: PGF}
 readPGF :: FilePath -> IO PGF
 readPGF fpath =
   do pool <- gu_new_pool
-     pgf  <- withCString fpath $ \c_fpath -> 
+     pgf  <- withCString fpath $ \c_fpath ->
-               pgf_read c_fpath pool nullPtr
+               withGuPool $ \tmpPl -> do
+                 exn <- gu_new_exn nullPtr gu_type__type tmpPl
+                 pgf <- pgf_read c_fpath pool exn
+                 failed <- gu_exn_is_raised exn
+                 if failed
+                   then do ty <- gu_exn_caught exn
+                           if ty == gu_type__GuErrno
+                             then do perrno <- (#peek GuExn, data.data) exn
+                                     errno  <- peek perrno
+                                     ioError (errnoToIOError "readPGF" (Errno errno) Nothing (Just fpath))
+                             else throw (PGFError "The grammar cannot be loaded")
+                   else return pgf
      master <- newForeignPtr gu_pool_finalizer pool
      return PGF {pgf = pgf, pgfMaster = master}
 
@@ -203,9 +216,20 @@ linearize :: Concr -> Expr -> String
 linearize lang e = unsafePerformIO $
   withGuPool $ \pl ->
     do (sb,out) <- newOut pl
-       pgf_linearize (concr lang) (expr e) out nullPtr
+       exn <- gu_new_exn nullPtr gu_type__type pl
-       lin <- gu_string_buf_freeze sb pl
+       pgf_linearize (concr lang) (expr e) out exn
-       peekCString lin
+       failed <- gu_exn_is_raised exn
+       if failed
+         then do ty <- gu_exn_caught exn
+                 if ty == gu_type__PgfLinNonExist
+                   then return ""
+                   else if ty == gu_type__PgfExn
+                          then do c_msg <- (#peek GuExn, data.data) exn
+                                  msg <- peekCString c_msg
+                                  throw (PGFError msg)
+                          else throw (PGFError "The abstract tree cannot be linearized")
+         else do lin <- gu_string_buf_freeze sb pl
+                 peekCString lin
 
 
 -----------------------------------------------------------------------------
@@ -230,3 +254,11 @@ fromPgfExprEnum enum fpl master =
                ts <- unsafeInterleaveIO (fromPgfExprEnum enum fpl master)
                prob <- (#peek PgfExprProb, prob) pgfExprProb
                return ((Expr expr master,prob) : ts)
+
+-----------------------------------------------------------------------
+-- Exceptions
+
+newtype PGFError = PGFError String
+     deriving (Show, Typeable)
+
+instance Exception PGFError

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

@@ -15,6 +15,7 @@ data GuEnum
 data GuExn
 data GuIn
 data GuKind
+data GuType
 data GuString
 data GuStringBuf
 data GuMapItor
@@ -36,9 +37,21 @@ foreign import ccall "gu/exn.h gu_new_exn"
 foreign import ccall "gu/exn.h gu_exn_is_raised"
   gu_exn_is_raised :: Ptr GuExn -> IO Bool
 
+foreign import ccall "gu/exn.h gu_exn_caught"
+  gu_exn_caught :: Ptr GuExn -> IO (Ptr GuType)
+
 foreign import ccall "gu/type.h &gu_type__type"
   gu_type__type :: Ptr GuKind
 
+foreign import ccall "gu/type.h &gu_type__GuErrno"
+  gu_type__GuErrno :: Ptr GuType
+
+foreign import ccall "gu/type.h &gu_type__PgfLinNonExist"
+  gu_type__PgfLinNonExist :: Ptr GuType
+
+foreign import ccall "gu/type.h &gu_type__PgfExn"
+  gu_type__PgfExn :: Ptr GuType
+
 foreign import ccall "gu/string.h gu_string_in"
   gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn)