diff options
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 24 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/FFI.hs | 3 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/examples/pgf-shell.hs | 8 |
3 files changed, 28 insertions, 7 deletions
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 5944e2369..2ed1e28b9 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/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 - parseFPl <- newForeignPtr gu_pool_finalizer parsePl - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - fromPgfExprEnum enum parseFPl (lang,exprFPl) + pgf_parse (concr lang) cat sent exn parsePl exprPl + failed <- gu_exn_is_raised exn + if failed + 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 $ diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index 45faef8eb..35ed15958 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/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) diff --git a/src/runtime/haskell-bind/examples/pgf-shell.hs b/src/runtime/haskell-bind/examples/pgf-shell.hs index e111076d4..bb15508c7 100644 --- a/src/runtime/haskell-bind/examples/pgf-shell.hs +++ b/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 |