diff options
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 22 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/test.hs | 18 |
2 files changed, 31 insertions, 9 deletions
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 21e8693eb..b3b349ee1 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -988,11 +988,27 @@ complete lang (Type ctype _) sent pfx mn = failed <- gu_exn_is_raised exn if failed then do - -- TODO better error handling, cleanup is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError if is_parse_error - then return (ParseFailed 0 "") - else throwIO (PGFError "Some other error") + then do + c_err <- (#peek GuExn, data.data) exn + c_offset <- (#peek PgfParseError, offset) c_err + token_ptr <- (#peek PgfParseError, token_ptr) c_err + token_len <- (#peek PgfParseError, token_len) c_err + tok <- peekUtf8CStringLen token_ptr token_len + gu_pool_free parsePl + return (ParseFailed (fromIntegral (c_offset :: CInt)) tok) + else 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 + gu_pool_free parsePl + throwIO (PGFError msg) + else do + gu_pool_free parsePl + throwIO (PGFError "Parsing failed") else do fpl <- newForeignPtr gu_pool_finalizer parsePl ParseOk <$> fromCompletions enum fpl diff --git a/src/runtime/haskell-bind/test.hs b/src/runtime/haskell-bind/test.hs index 26836445f..4d345c90c 100644 --- a/src/runtime/haskell-bind/test.hs +++ b/src/runtime/haskell-bind/test.hs @@ -4,9 +4,15 @@ import qualified Data.Map as M main :: IO () main = do pgf <- readPGF "/Users/john/repositories/GF/contrib/foods/Foods.pgf" - let Just concr = M.lookup "FoodsEng" (languages pgf) - let pr = complete concr (startCat pgf) "" "th" Nothing - case pr of - ParseOk x -> print x - ParseFailed _ _ -> putStrLn "parse failed" - ParseIncomplete -> putStrLn "input incomplete" + let + Just concr = M.lookup "FoodsEng" (languages pgf) + loop = do + putStr "> " + tks <- words <$> getLine + let pr = complete concr (startCat pgf) (unwords (init tks)) (last tks) Nothing + case pr of + ParseOk x -> print x + ParseFailed x s -> putStrLn $ "parse failed at " ++ show x ++ " " ++ s + ParseIncomplete -> putStrLn "input incomplete" + loop + loop |