From 1c04fa4897acfa2119fa32850bfcd6550b712da4 Mon Sep 17 00:00:00 2001
From: Krasimir Angelov <kr.angelov@gmail.com>
Date: Thu, 28 Sep 2017 13:57:13 +0200
Subject: the parser for abstract expressions in the C runtime now supports
 partial parses

---
 src/runtime/haskell-bind/PGF2/Expr.hsc | 45 +++++++++++++++++++++++++++++++++-
 src/runtime/haskell-bind/PGF2/FFI.hsc  |  7 ++++--
 src/runtime/haskell-bind/PGF2/Type.hsc |  2 +-
 3 files changed, 50 insertions(+), 4 deletions(-)

(limited to 'src/runtime/haskell-bind/PGF2')

diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc
index 90f702462..096d15bfa 100644
--- a/src/runtime/haskell-bind/PGF2/Expr.hsc
+++ b/src/runtime/haskell-bind/PGF2/Expr.hsc
@@ -5,6 +5,7 @@ module PGF2.Expr where
 import System.IO.Unsafe(unsafePerformIO)
 import Foreign hiding (unsafePerformIO)
 import Foreign.C
+import Data.IORef
 import PGF2.FFI
 
 -- | An data type that represents
@@ -195,7 +196,7 @@ readExpr str =
          do c_str <- newUtf8CString str tmpPl
             guin <- gu_string_in c_str tmpPl
             exn <- gu_new_exn tmpPl
-            c_expr <- pgf_read_expr guin exprPl exn
+            c_expr <- pgf_read_expr guin exprPl tmpPl exn
             status <- gu_exn_is_raised exn
             if (not status && c_expr /= nullPtr)
               then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
@@ -203,6 +204,48 @@ readExpr str =
               else do gu_pool_free exprPl
                       return Nothing
 
+pExpr :: ReadS Expr
+pExpr str =
+  unsafePerformIO $
+    do exprPl <- gu_new_pool
+       withGuPool $ \tmpPl ->
+         do ref <- newIORef (str,str,str)
+            exn <- gu_new_exn tmpPl
+            c_fetch_char <- wrapParserGetc (fetch_char ref)
+            c_parser <- pgf_new_parser nullPtr c_fetch_char exprPl tmpPl exn
+            c_expr <- pgf_expr_parser_expr c_parser 1
+            status <- gu_exn_is_raised exn
+            if (not status && c_expr /= nullPtr)
+              then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
+                      (str,_,_) <- readIORef ref
+                      return [(Expr c_expr (touchForeignPtr exprFPl),str)]
+              else do gu_pool_free exprPl
+                      return []
+  where
+    fetch_char :: IORef (String,String,String) -> Ptr () -> (#type bool) -> Ptr GuExn -> IO (#type GuUCS)
+    fetch_char ref _ mark exn = do
+      (str1,str2,str3) <- readIORef ref
+      let str1' = if mark /= 0
+                    then str2
+                    else str1
+      case str3 of
+        []     -> do writeIORef ref (str1',str3,[])
+                     gu_exn_raise exn gu_exn_type_GuEOF
+                     return (-1)
+        (c:cs) -> do writeIORef ref (str1',str3,cs)
+                     return ((fromIntegral . fromEnum) c)
+
+foreign import ccall "pgf/expr.h pgf_new_parser"
+  pgf_new_parser :: Ptr () -> (FunPtr ParserGetc) -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfExprParser)
+
+foreign import ccall "pgf/expr.h pgf_expr_parser_expr"
+  pgf_expr_parser_expr :: Ptr PgfExprParser -> (#type bool) -> IO PgfExpr
+
+type ParserGetc = Ptr () -> (#type bool) -> Ptr GuExn -> IO (#type GuUCS)
+
+foreign import ccall "wrapper"
+  wrapParserGetc :: ParserGetc -> IO (FunPtr ParserGetc)
+
 -- | renders an expression as a 'String'. The list
 -- of identifiers is the list of all free variables
 -- in the expression in order reverse to the order
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc
index 1ed145160..c095e663f 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hsc
+++ b/src/runtime/haskell-bind/PGF2/FFI.hsc
@@ -78,6 +78,8 @@ foreign import ccall unsafe "gu/exn.h gu_exn_raise_"
 
 gu_exn_type_GuErrno = Ptr "GuErrno"## :: CString
 
+gu_exn_type_GuEOF = Ptr "GuEOF"## :: CString
+
 gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"## :: CString
 
 gu_exn_type_PgfExn = Ptr "PgfExn"## :: CString
@@ -222,6 +224,7 @@ data PgfApplication
 data PgfConcr
 type PgfExpr = Ptr ()
 data PgfExprProb
+data PgfExprParser
 data PgfFullFormEntry
 data PgfMorphoCallback
 data PgfPrintContext
@@ -462,7 +465,7 @@ foreign import ccall "pgf/pgf.h pgf_print"
   pgf_print :: Ptr PgfPGF -> Ptr GuOut -> Ptr GuExn -> IO ()
 
 foreign import ccall "pgf/expr.h pgf_read_expr"
-  pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr
+  pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr
 
 foreign import ccall "pgf/expr.h pgf_read_expr_tuple"
   pgf_read_expr_tuple :: Ptr GuIn -> CSizeT -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt
@@ -471,7 +474,7 @@ foreign import ccall "pgf/expr.h pgf_read_expr_matrix"
   pgf_read_expr_matrix :: Ptr GuIn -> CSizeT -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq)
 
 foreign import ccall "pgf/expr.h pgf_read_type"
-  pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfType
+  pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfType
 
 foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree"
   pgf_graphviz_abstract_tree :: Ptr PgfPGF -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()
diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell-bind/PGF2/Type.hsc
index 61e46b4ef..06b137b1f 100644
--- a/src/runtime/haskell-bind/PGF2/Type.hsc
+++ b/src/runtime/haskell-bind/PGF2/Type.hsc
@@ -31,7 +31,7 @@ readType str =
          do c_str <- newUtf8CString str tmpPl
             guin <- gu_string_in c_str tmpPl
             exn <- gu_new_exn tmpPl
-            c_type <- pgf_read_type guin typPl exn
+            c_type <- pgf_read_type guin typPl tmpPl exn
             status <- gu_exn_is_raised exn
             if (not status && c_type /= nullPtr)
               then do typFPl <- newForeignPtr gu_pool_finalizer typPl
-- 
cgit v1.2.3