diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 81 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/FFI.hs | 24 |
2 files changed, 104 insertions, 1 deletions
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 60b805acd..1d9d82f90 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -14,6 +14,7 @@ ------------------------------------------------- #include <pgf/pgf.h> +#include <pgf/linearizer.h> #include <gu/enum.h> #include <gu/exn.h> @@ -51,7 +52,7 @@ module PGF2 (-- * PGF -- * Concrete syntax ConcName,Concr,languages, -- ** Linearization - linearize,linearizeAll,tabularLinearize, + linearize,linearizeAll,tabularLinearize,bracketedLinearize, FId, LIndex, BracketedString(..), showBracketedString, flattenBracketedString, alignWords, @@ -725,6 +726,84 @@ flattenBracketedString :: BracketedString -> [String] flattenBracketedString (Leaf w) = [w] flattenBracketedString (Bracket _ _ _ _ bss) = concatMap flattenBracketedString bss +bracketedLinearize :: Concr -> Expr -> [BracketedString] +bracketedLinearize lang e = unsafePerformIO $ + withGuPool $ \pl -> + do exn <- gu_new_exn pl + cts <- pgf_lzr_concretize (concr lang) (expr e) exn pl + failed <- gu_exn_is_raised exn + if failed + then throwExn exn + else do ctree <- alloca $ \ptr -> do gu_enum_next cts ptr pl + peek ptr + if ctree == nullPtr + then do touchExpr e + return [] + else do ctree <- pgf_lzr_wrap_linref ctree pl + ref <- newIORef ([],[]) + allocaBytes (#size PgfLinFuncs) $ \pLinFuncs -> + alloca $ \ppLinFuncs -> do + fptr_symbol_token <- wrapSymbolTokenCallback (symbol_token ref) + fptr_begin_phrase <- wrapPhraseCallback (begin_phrase ref) + fptr_end_phrase <- wrapPhraseCallback (end_phrase ref) + fptr_symbol_ne <- wrapSymbolNonExistCallback (symbol_ne exn) + fptr_symbol_meta <- wrapSymbolMetaCallback (symbol_meta ref) + (#poke PgfLinFuncs, symbol_token) pLinFuncs fptr_symbol_token + (#poke PgfLinFuncs, begin_phrase) pLinFuncs fptr_begin_phrase + (#poke PgfLinFuncs, end_phrase) pLinFuncs fptr_end_phrase + (#poke PgfLinFuncs, symbol_ne) pLinFuncs fptr_symbol_ne + (#poke PgfLinFuncs, symbol_bind) pLinFuncs nullPtr + (#poke PgfLinFuncs, symbol_capit) pLinFuncs nullPtr + (#poke PgfLinFuncs, symbol_meta) pLinFuncs fptr_symbol_meta + poke ppLinFuncs pLinFuncs + pgf_lzr_linearize (concr lang) ctree 0 ppLinFuncs pl + freeHaskellFunPtr fptr_symbol_token + freeHaskellFunPtr fptr_begin_phrase + freeHaskellFunPtr fptr_end_phrase + freeHaskellFunPtr fptr_symbol_ne + freeHaskellFunPtr fptr_symbol_meta + failed <- gu_exn_is_raised exn + if failed + then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist + if is_nonexist + then return [] + else throwExn exn + else do (_,bs) <- readIORef ref + return (reverse bs) + where + symbol_token ref _ c_token = do + (stack,bs) <- readIORef ref + token <- peekUtf8CString c_token + writeIORef ref (stack,Leaf token : bs) + + begin_phrase ref _ c_cat c_fid c_lindex c_fun = do + (stack,bs) <- readIORef ref + writeIORef ref (bs:stack,[]) + + end_phrase ref _ c_cat c_fid c_lindex c_fun = do + (bs':stack,bs) <- readIORef ref + cat <- peekUtf8CString c_cat + let fid = fromIntegral c_fid + let lindex = fromIntegral c_lindex + fun <- peekUtf8CString c_fun + writeIORef ref (stack, Bracket cat fid lindex fun (reverse bs) : bs') + + symbol_ne exn _ = do + gu_exn_raise exn gu_exn_type_PgfLinNonExist + return () + + symbol_meta ref _ meta_id = do + (stack,bs) <- readIORef ref + writeIORef ref (stack,Leaf "?" : bs) + + throwExn exn = 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 + throwIO (PGFError msg) + else do throwIO (PGFError "The abstract tree cannot be linearized") + alignWords :: Concr -> Expr -> [(String, [Int])] alignWords lang e = unsafePerformIO $ withGuPool $ \pl -> diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index ae217b46a..d01084d62 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -55,6 +55,9 @@ foreign import ccall "gu/exn.h gu_exn_is_raised" foreign import ccall "gu/exn.h gu_exn_caught_" gu_exn_caught :: Ptr GuExn -> CString -> IO Bool +foreign import ccall "gu/exn.h gu_exn_raise_" + gu_exn_raise :: Ptr GuExn -> CString -> IO (Ptr ()) + gu_exn_type_GuErrno = Ptr "GuErrno"# :: CString gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"# :: CString @@ -144,6 +147,7 @@ type PgfType = Ptr () data PgfCallbacksMap data PgfOracleCallback data PgfCncTree +data PgfLinFuncs foreign import ccall "pgf/pgf.h pgf_read" pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF) @@ -202,9 +206,29 @@ foreign import ccall "pgf/pgf.h pgf_lzr_wrap_linref" foreign import ccall "pgf/pgf.h pgf_lzr_linearize_simple" pgf_lzr_linearize_simple :: Ptr PgfConcr -> Ptr PgfCncTree -> CInt -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO () +foreign import ccall "pgf/pgf.h pgf_lzr_linearize" + pgf_lzr_linearize :: Ptr PgfConcr -> Ptr PgfCncTree -> CInt -> Ptr (Ptr PgfLinFuncs) -> Ptr GuPool -> IO () + foreign import ccall "pgf/pgf.h pgf_lzr_get_table" pgf_lzr_get_table :: Ptr PgfConcr -> Ptr PgfCncTree -> Ptr CInt -> Ptr (Ptr CString) -> IO () +type SymbolTokenCallback = Ptr (Ptr PgfLinFuncs) -> CString -> IO () +type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CInt -> CString -> IO () +type NonExistCallback = Ptr (Ptr PgfLinFuncs) -> IO () +type MetaCallback = Ptr (Ptr PgfLinFuncs) -> CInt -> IO () + +foreign import ccall "wrapper" + wrapSymbolTokenCallback :: SymbolTokenCallback -> IO (FunPtr SymbolTokenCallback) + +foreign import ccall "wrapper" + wrapPhraseCallback :: PhraseCallback -> IO (FunPtr PhraseCallback) + +foreign import ccall "wrapper" + wrapSymbolNonExistCallback :: NonExistCallback -> IO (FunPtr NonExistCallback) + +foreign import ccall "wrapper" + wrapSymbolMetaCallback :: MetaCallback -> IO (FunPtr MetaCallback) + foreign import ccall "pgf/pgf.h pgf_align_words" pgf_align_words :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuSeq) |