manually copy the "c-runtime" branch from the old repository.

src/runtime/haskell-bind/PGF2/Expr.hsc

@@ -8,19 +8,13 @@ import Foreign.C
 import Data.IORef
 import PGF2.FFI
 
--- | An data type that represents
--- identifiers for functions and categories in PGF.
-type CId = String
-
-wildCId = "_" :: CId
-
-type Cat = CId -- ^ Name of syntactic category
-type Fun = CId -- ^ Name of function
+type Cat = String -- ^ Name of syntactic category
+type Fun = String -- ^ Name of function
 
 data BindType = 
     Explicit
   | Implicit
-  deriving Show
+  deriving (Show, Eq, Ord)
 
 -----------------------------------------------------------------------------
 -- Expressions
@@ -43,7 +37,7 @@ instance Eq Expr where
       return (res /= 0)
 
 -- | Constructs an expression by lambda abstraction
-mkAbs :: BindType -> CId -> Expr -> Expr
+mkAbs :: BindType -> String -> Expr -> Expr
 mkAbs bind_type var (Expr body bodyTouch) =
   unsafePerformIO $ do
       exprPl <- gu_new_pool
@@ -58,7 +52,7 @@ mkAbs bind_type var (Expr body bodyTouch) =
         Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
 
 -- | Decomposes an expression into an abstraction and a body
-unAbs :: Expr -> Maybe (BindType, CId, Expr)
+unAbs :: Expr -> Maybe (BindType, String, Expr)
 unAbs (Expr expr touch) =
   unsafePerformIO $ do
       c_abs <- pgf_expr_unabs expr
@@ -103,6 +97,17 @@ unApp (Expr expr touch) =
            c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args))
            return $ Just (fun, [Expr c_arg touch | c_arg <- c_args])
 
+-- | Decomposes an expression into an application of a function
+unapply :: Expr -> (Expr,[Expr])
+unapply (Expr expr touch) =
+  unsafePerformIO $
+    withGuPool $ \pl -> do
+      appl <- pgf_expr_unapply_ex expr pl
+      efun  <- (#peek PgfApplication, efun) appl
+      arity <- (#peek PgfApplication, n_args) appl :: IO CInt 
+      c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args))
+      return (Expr efun touch, [Expr c_arg touch | c_arg <- c_args])
+
 -- | Constructs an expression from a string literal
 mkStr :: String -> Expr
 mkStr str =
@@ -184,9 +189,6 @@ unMeta (Expr expr touch) =
                 touch
                 return (Just (fromIntegral (id :: CInt)))
 
--- | this functions is only for backward compatibility with the old Haskell runtime
-mkCId x = x
-
 -- | parses a 'String' as an expression
 readExpr :: String -> Maybe Expr
 readExpr str =
@@ -204,6 +206,22 @@ readExpr str =
               else do gu_pool_free exprPl
                       return Nothing
 
+pIdent :: ReadS String
+pIdent str =
+  unsafePerformIO $
+    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 tmpPl tmpPl exn
+          c_ident <- pgf_expr_parser_ident c_parser
+          status <- gu_exn_is_raised exn
+          if (not status && c_ident /= nullPtr)
+            then do ident <- peekUtf8CString c_ident
+                    (str,_,_) <- readIORef ref
+                    return [(ident,str)]
+            else do return []
+
 pExpr :: ReadS Expr
 pExpr str =
   unsafePerformIO $
@@ -221,19 +239,19 @@ pExpr str =
                       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)
+
+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)
@@ -241,16 +259,20 @@ foreign import ccall "pgf/expr.h pgf_new_parser"
 foreign import ccall "pgf/expr.h pgf_expr_parser_expr"
   pgf_expr_parser_expr :: Ptr PgfExprParser -> (#type bool) -> IO PgfExpr
 
+foreign import ccall "pgf/expr.h pgf_expr_parser_ident"
+  pgf_expr_parser_ident :: Ptr PgfExprParser -> IO CString
+
 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
 -- of binding.
-showExpr :: [CId] -> Expr -> String
+showExpr :: [String] -> Expr -> String
 showExpr scope e = 
   unsafePerformIO $
     withGuPool $ \tmpPl ->