diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index a6a53e155..9718f4fa6 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -42,6 +42,9 @@ module PGF2 (-- * PGF readType, showType, mkType, unType, + -- ** Type checking + checkExpr, inferExpr, checkType, + -- * Concrete syntax ConcName,Concr,languages, -- ** Linearization @@ -66,7 +69,7 @@ module PGF2 (-- * PGF ) where import Prelude hiding (fromEnum) -import Control.Exception(Exception,throwIO) +import Control.Exception(Exception,throwIO,throw) import Control.Monad(forM_) import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO) import Text.PrettyPrint @@ -203,6 +206,79 @@ functionType p fn = then throwIO (PGFError ("Function '"++fn++"' is not defined")) else return (Type c_type (pgfMaster p)) +-- | Checks an expression against a specified type. +checkExpr :: PGF -> Expr -> Type -> Either String Expr +checkExpr (PGF p _) (Expr c_expr _) (Type c_ty _) = + unsafePerformIO $ + alloca $ \pexpr -> + withGuPool $ \tmpPl -> do + exn <- gu_new_exn tmpPl + exprPl <- gu_new_pool + poke pexpr c_expr + pgf_check_expr p pexpr c_ty exn exprPl + status <- gu_exn_is_raised exn + if not status + then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl + c_expr <- peek pexpr + return (Right (Expr c_expr exprFPl)) + else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError + c_msg <- (#peek GuExn, data.data) exn + msg <- peekUtf8CString c_msg + gu_pool_free exprPl + if is_tyerr + then return (Left msg) + else throw (PGFError msg) + +-- | Tries to infer the type of an expression. Note that +-- even if the expression is type correct it is not always +-- possible to infer its type in the GF type system. +-- In this case the function returns an error. +inferExpr :: PGF -> Expr -> Either String (Expr, Type) +inferExpr (PGF p _) (Expr c_expr _) = + unsafePerformIO $ + alloca $ \pexpr -> + withGuPool $ \tmpPl -> do + exn <- gu_new_exn tmpPl + exprPl <- gu_new_pool + poke pexpr c_expr + c_ty <- pgf_infer_expr p pexpr exn exprPl + status <- gu_exn_is_raised exn + if not status + then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl + c_expr <- peek pexpr + return (Right (Expr c_expr exprFPl, Type c_ty exprFPl)) + else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError + c_msg <- (#peek GuExn, data.data) exn + msg <- peekUtf8CString c_msg + gu_pool_free exprPl + if is_tyerr + then return (Left msg) + else throw (PGFError msg) + +-- | Check whether a type is consistent with the abstract +-- syntax of the grammar. +checkType :: PGF -> Type -> Either String Type +checkType (PGF p _) (Type c_ty _) = + unsafePerformIO $ + alloca $ \pty -> + withGuPool $ \tmpPl -> do + exn <- gu_new_exn tmpPl + typePl <- gu_new_pool + poke pty c_ty + pgf_check_type p pty exn typePl + status <- gu_exn_is_raised exn + if not status + then do typeFPl <- newForeignPtr gu_pool_finalizer typePl + c_ty <- peek pty + return (Right (Type c_ty typeFPl)) + else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError + c_msg <- (#peek GuExn, data.data) exn + msg <- peekUtf8CString c_msg + gu_pool_free typePl + if is_tyerr + then return (Left msg) + else throw (PGFError msg) + ----------------------------------------------------------------------------- -- Graphviz diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index 949c46471..5ae2ced06 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -61,6 +61,8 @@ gu_exn_type_PgfExn = Ptr "PgfExn"# :: CString gu_exn_type_PgfParseError = Ptr "PgfParseError"# :: CString +gu_exn_type_PgfTypeError = Ptr "PgfTypeError"# :: CString + foreign import ccall "gu/string.h gu_string_in" gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn) @@ -290,6 +292,16 @@ foreign import ccall "pgf/pgf.h pgf_expr_unlit" foreign import ccall "pgf/expr.h pgf_expr_arity" pgf_expr_arity :: PgfExpr -> IO CInt +foreign import ccall "pgf/expr.h pgf_check_expr" + pgf_check_expr :: Ptr PgfPGF -> Ptr PgfExpr -> PgfType -> Ptr GuExn -> Ptr GuPool -> IO () + +foreign import ccall "pgf/expr.h pgf_infer_expr" + pgf_infer_expr :: Ptr PgfPGF -> Ptr PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO PgfType + +foreign import ccall "pgf/expr.h pgf_check_type" + pgf_check_type :: Ptr PgfPGF -> Ptr PgfType -> Ptr GuExn -> Ptr GuPool -> IO () + + foreign import ccall "pgf/expr.h pgf_print_expr" pgf_print_expr :: PgfExpr -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()