fix the haskell binding to handle parse errors

src/runtime/haskell-bind/PGF2.hsc

@@ -200,17 +200,31 @@ getAnalysis ref self c_lemma c_anal prob exn = do
   anal  <- peekCString c_anal
   writeIORef ref ((lemma, anal, prob):ans)
 
-parse :: Concr -> String -> String -> [(Expr,Float)]
+parse :: Concr -> String -> String -> Either String [(Expr,Float)]
 parse lang cat sent =
   unsafePerformIO $
     do parsePl <- gu_new_pool
        exprPl  <- gu_new_pool
+       exn     <- gu_new_exn nullPtr gu_type__type parsePl
        enum    <- withCString cat $ \cat ->
                     withCString sent $ \sent ->
-                      pgf_parse (concr lang) cat sent nullPtr parsePl exprPl
+                      pgf_parse (concr lang) cat sent exn parsePl exprPl
-       parseFPl <- newForeignPtr gu_pool_finalizer parsePl
+       failed  <- gu_exn_is_raised exn
-       exprFPl  <- newForeignPtr gu_pool_finalizer exprPl
+       if failed
-       fromPgfExprEnum enum parseFPl (lang,exprFPl)
+         then do ty <- gu_exn_caught exn
+                 if ty == gu_type__PgfParseError
+                   then do c_tok <- (#peek GuExn, data.data) exn
+                           tok <- peekCString c_tok
+                           return (Left tok)
+                   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 "Parsing failed")
+         else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl
+                 exprFPl  <- newForeignPtr gu_pool_finalizer exprPl
+                 exprs    <- fromPgfExprEnum enum parseFPl (lang,exprFPl)
+                 return (Right exprs)
 
 linearize :: Concr -> Expr -> String
 linearize lang e = unsafePerformIO $

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

@@ -51,6 +51,9 @@ foreign import ccall "gu/type.h &gu_type__PgfLinNonExist"
 
 foreign import ccall "gu/type.h &gu_type__PgfExn"
   gu_type__PgfExn :: Ptr GuType
+  
+foreign import ccall "gu/type.h &gu_type__PgfParseError"
+  gu_type__PgfParseError :: Ptr GuType
 
 foreign import ccall "gu/string.h gu_string_in"
   gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn)

src/runtime/haskell-bind/examples/pgf-shell.hs

@@ -34,10 +34,14 @@ execute pgf cmd =
     L lang tree -> do c <- getConcr' pgf lang
                       putStrLn $ linearize c tree
     P lang s    -> do c <- getConcr' pgf lang
-                      printl $ parse c (startCat pgf) s
+                      case parse c (startCat pgf) s of
+                        Left tok -> putStrLn ("parse error: "++tok)
+                        Right ts -> printl ts
     T from to s -> do cfrom <- getConcr' pgf from
                       cto   <- getConcr' pgf to
-                      putl [linearize cto t|(t,_)<-parse cfrom (startCat pgf) s]
+                      putl [linearize cto t|(t,_)<-case parse cfrom (startCat pgf) s of
+                                                     Left _   -> []
+                                                     Right ts -> ts]
     _ -> putStrLn "Huh?"
   `catch` print