diff options
| -rw-r--r-- | src/runtime/haskell-bind/PGF2.hsc | 12 | ||||
| -rw-r--r-- | src/runtime/haskell-bind/PGF2/FFI.hsc | 4 |
2 files changed, 15 insertions, 1 deletions
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 895d13ca4..64ac1953c 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -862,6 +862,7 @@ type LIndex = Int -- mark the beginning and the end of each constituent. data BracketedString = Leaf String -- ^ this is the leaf i.e. a single token + | BIND -- ^ the surrounding tokens must be bound together | Bracket CId {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex CId [BracketedString] -- ^ this is a bracket. The 'CId' is the category of -- the phrase. The 'FId' is an unique identifier for @@ -884,11 +885,13 @@ showBracketedString :: BracketedString -> String showBracketedString = render . ppBracketedString ppBracketedString (Leaf t) = text t +ppBracketedString BIND = text "&+" ppBracketedString (Bracket cat fid index _ bss) = parens (text cat <> colon <> int fid <+> hsep (map ppBracketedString bss)) -- | Extracts the sequence of tokens from the bracketed string flattenBracketedString :: BracketedString -> [String] flattenBracketedString (Leaf w) = [w] +flattenBracketedString BIND = [] flattenBracketedString (Bracket _ _ _ _ bss) = concatMap flattenBracketedString bss bracketedLinearize :: Concr -> Expr -> [BracketedString] @@ -912,12 +915,13 @@ bracketedLinearize lang e = unsafePerformIO $ fptr_begin_phrase <- wrapPhraseCallback (begin_phrase ref) fptr_end_phrase <- wrapPhraseCallback (end_phrase ref) fptr_symbol_ne <- wrapSymbolNonExistCallback (symbol_ne exn) + fptr_symbol_bind <- wrapSymbolBindCallback (symbol_bind ref) 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_bind) pLinFuncs fptr_symbol_bind (#poke PgfLinFuncs, symbol_capit) pLinFuncs nullPtr (#poke PgfLinFuncs, symbol_meta) pLinFuncs fptr_symbol_meta poke ppLinFuncs pLinFuncs @@ -926,6 +930,7 @@ bracketedLinearize lang e = unsafePerformIO $ freeHaskellFunPtr fptr_begin_phrase freeHaskellFunPtr fptr_end_phrase freeHaskellFunPtr fptr_symbol_ne + freeHaskellFunPtr fptr_symbol_bind freeHaskellFunPtr fptr_symbol_meta failed <- gu_exn_is_raised exn if failed @@ -957,6 +962,11 @@ bracketedLinearize lang e = unsafePerformIO $ gu_exn_raise exn gu_exn_type_PgfLinNonExist return () + symbol_bind ref _ = do + (stack,bs) <- readIORef ref + writeIORef ref (stack,BIND : bs) + return () + symbol_meta ref _ meta_id = do (stack,bs) <- readIORef ref writeIORef ref (stack,Leaf "?" : bs) diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc index c33f1da50..39b18fcf3 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hsc +++ b/src/runtime/haskell-bind/PGF2/FFI.hsc @@ -340,6 +340,7 @@ foreign import ccall "pgf/pgf.h pgf_lzr_get_table" type SymbolTokenCallback = Ptr (Ptr PgfLinFuncs) -> CString -> IO () type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CSizeT -> CString -> IO () type NonExistCallback = Ptr (Ptr PgfLinFuncs) -> IO () +type BindCallback = Ptr (Ptr PgfLinFuncs) -> IO () type MetaCallback = Ptr (Ptr PgfLinFuncs) -> CInt -> IO () foreign import ccall "wrapper" @@ -352,6 +353,9 @@ foreign import ccall "wrapper" wrapSymbolNonExistCallback :: NonExistCallback -> IO (FunPtr NonExistCallback) foreign import ccall "wrapper" + wrapSymbolBindCallback :: BindCallback -> IO (FunPtr BindCallback) + +foreign import ccall "wrapper" wrapSymbolMetaCallback :: MetaCallback -> IO (FunPtr MetaCallback) foreign import ccall "pgf/pgf.h pgf_align_words" |