added PGF(pIdent,pExpr)

src/compiler/GF/Command/Parse.hs

@@ -1,6 +1,6 @@
 module GF.Command.Parse(readCommandLine, pCommand) where
 
-import PGF2(pExpr,pIdent)
+import PGF(pExpr,pIdent)
 import GF.Grammar.Parser(runPartial,pTerm)
 import GF.Command.Abstract
 
@@ -22,7 +22,7 @@ pCommandLine =
 pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|')
 
 pCommand = (do
-  cmd  <- readS_to_P pIdent <++ (char '%' >> fmap ('%':) (readS_to_P pIdent))
+  cmd  <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
   skipSpaces
   opts <- sepBy pOption skipSpaces
   arg  <- if getCommandOp cmd == "cc" then pArgTerm else pArgument
@@ -37,7 +37,7 @@ pCommand = (do
 
 pOption = do
   char '-'
-  flg <- readS_to_P pIdent
+  flg <- pIdent
   option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
 
 pValue = do
@@ -52,9 +52,9 @@ pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
 
 pArgument =
   option ANoArg
-    (fmap AExpr (readS_to_P pExpr)
+    (fmap AExpr pExpr
               <++
-    (skipSpaces >> char '%' >> fmap AMacro (readS_to_P pIdent)))
+    (skipSpaces >> char '%' >> fmap AMacro pIdent))
 
 pArgTerm = ATerm `fmap` readS_to_P sTerm
   where

src/runtime/c/pgf/expr.cxx

@@ -227,6 +227,7 @@ PgfExprParser::PgfExprParser(PgfText *input, PgfUnmarshaller *unmarshaller)
     pos = (const char*) &inp->text;
 	ch  = ' ';
     u   = unmarshaller;
+    token_pos = NULL;
     token_value = NULL;
 
 	token();
@@ -347,16 +348,18 @@ void PgfExprParser::str_char()
 
 void PgfExprParser::token()
 {
-	while (isspace(ch)) {
-		ch = getc();
-	}
-
     if (token_value != NULL)
         free(token_value);
 
 	token_tag   = PGF_TOKEN_UNKNOWN;
+    token_pos   = pos;
 	token_value = NULL;
 
+	while (isspace(ch)) {
+        token_pos   = pos;
+		ch = getc();
+	}
+
 	switch (ch) {
 	case EOF:
 		ch = getc();
@@ -921,7 +924,6 @@ exit:
     return type;
 }
 
-
 PGF_INTERNAL
 void pgf_literal_free(PgfLiteral literal)
 {

src/runtime/c/pgf/expr.h

@@ -207,7 +207,7 @@ class PGF_INTERNAL_DECL PgfExprParser {
 	PGF_TOKEN_TAG token_tag;
 	PgfText *token_value;
     PgfText *inp;
-    const char *pos;
+    const char *token_pos, *pos;
     uint32_t ch;
 
     uint32_t getc();
@@ -224,7 +224,6 @@ public:
     PgfBind *parse_bind(PgfBind *next);
     PgfBind *parse_binds(PgfBind *next);
 
-
     PgfExpr parse_arg();
     PgfExpr parse_term();
     PgfExpr parse_expr();
@@ -233,6 +232,8 @@ public:
     PgfType parse_type();
 
     bool eof();
+
+    const char *get_token_pos() { return token_pos; }
 };
 
 PGF_INTERNAL_DECL extern PgfText wildcard;

src/runtime/c/pgf/pgf.cxx

@@ -418,8 +418,8 @@ PgfText *pgf_print_expr(PgfExpr e,
     return printer.get_text();
 }
 
-PGF_API PgfExpr
+PGF_API
-pgf_read_expr(PgfText *input, PgfUnmarshaller *u)
+PgfExpr pgf_read_expr(PgfText *input, PgfUnmarshaller *u)
 {
     PgfExprParser parser(input, u);
     PgfExpr res = parser.parse_expr();
@@ -430,6 +430,15 @@ pgf_read_expr(PgfText *input, PgfUnmarshaller *u)
     return res;
 }
 
+PGF_API
+PgfExpr pgf_read_expr_ex(PgfText *input, const char **end_pos, PgfUnmarshaller *u)
+{
+    PgfExprParser parser(input, u);
+    PgfExpr expr = parser.parse_expr();
+    *end_pos = parser.get_token_pos();
+    return expr;
+}
+
 PGF_API
 PgfText *pgf_print_type(PgfType ty,
                         PgfPrintContext *ctxt, int prio,

src/runtime/c/pgf/pgf.h

@@ -317,6 +317,9 @@ PgfText *pgf_print_expr(PgfExpr e,
 PGF_API_DECL
 PgfExpr pgf_read_expr(PgfText *input, PgfUnmarshaller *u);
 
+PGF_API_DECL
+PgfExpr pgf_read_expr_ex(PgfText *input, const char **end_pos, PgfUnmarshaller *u);
+
 PGF_API_DECL
 PgfText *pgf_print_type(PgfType ty,
                         PgfPrintContext *ctxt, int prio,

src/runtime/haskell/PGF.hs

@@ -1,56 +0,0 @@
-module PGF ( PGF2.PGF, readPGF
-           , abstractName
-
-           , CId, mkCId, wildCId, showCId, readCId
-
-           , PGF2.categories, PGF2.categoryContext, PGF2.startCat
-           , functions, functionsByCat
-
-           , PGF2.Expr(..), PGF2.Literal(..), Tree
-           , PGF2.readExpr, PGF2.showExpr
-           , PGF2.mkAbs,    PGF2.unAbs
-           , PGF2.mkApp,    PGF2.unApp, PGF2.unapply
-           , PGF2.mkStr,    PGF2.unStr
-           , PGF2.mkInt,    PGF2.unInt
-           , PGF2.mkDouble, PGF2.unDouble
-           , PGF2.mkFloat,  PGF2.unFloat
-           , PGF2.mkMeta,   PGF2.unMeta
-           , PGF2.exprSize, PGF2.exprFunctions
-
-           , PGF2.Type(..), PGF2.Hypo
-           , PGF2.readType, PGF2.showType
-           , PGF2.mkType, PGF2.unType
-           , PGF2.mkHypo, PGF2.mkDepHypo, PGF2.mkImplHypo
-
-           , PGF2.PGFError(..)
-           ) where
-
-import qualified PGF2 as PGF2
-
-newtype CId = CId String deriving (Show,Read,Eq,Ord)
-
-type Language = CId
-
-readPGF = PGF2.readPGF
-
-
-readLanguage = readCId
-showLanguage (CId s) = s
-
-
-abstractName gr = CId (PGF2.abstractName gr)
-
-
-categories gr = map CId (PGF2.categories gr)
-
-
-functions gr  = map CId (PGF2.functions gr)
-functionsByCat gr (CId c) = map CId (PGF2.functionsByCat gr c)
-
-type Tree = PGF2.Expr
-
-
-mkCId x = CId x
-wildCId = CId "_"
-showCId (CId x) = x
-readCId s = Just (CId s)

src/runtime/haskell/PGF.hsc

@@ -0,0 +1,117 @@
+module PGF ( PGF2.PGF, readPGF
+           , abstractName
+
+           , CId, mkCId, wildCId, showCId, readCId, pIdent
+
+           , PGF2.categories, PGF2.categoryContext, PGF2.startCat
+           , functions, functionsByCat
+
+           , PGF2.Expr(..), PGF2.Literal(..), Tree
+           , PGF2.readExpr, PGF2.showExpr, pExpr
+           , PGF2.mkAbs,    PGF2.unAbs
+           , PGF2.mkApp,    PGF2.unApp, PGF2.unapply
+           , PGF2.mkStr,    PGF2.unStr
+           , PGF2.mkInt,    PGF2.unInt
+           , PGF2.mkDouble, PGF2.unDouble
+           , PGF2.mkFloat,  PGF2.unFloat
+           , PGF2.mkMeta,   PGF2.unMeta
+           , PGF2.exprSize, PGF2.exprFunctions
+
+           , PGF2.Type(..), PGF2.Hypo
+           , PGF2.readType, PGF2.showType
+           , PGF2.mkType, PGF2.unType
+           , PGF2.mkHypo, PGF2.mkDepHypo, PGF2.mkImplHypo
+
+           , PGF2.PGFError(..)
+           ) where
+
+import PGF2.FFI
+
+import Foreign
+import Foreign.C
+import Control.Exception(mask_)
+import Control.Monad
+import qualified PGF2 as PGF2
+import qualified Text.ParserCombinators.ReadP as RP
+import System.IO.Unsafe(unsafePerformIO)
+
+#include <pgf/pgf.h>
+
+newtype CId = CId String deriving (Show,Read,Eq,Ord)
+
+type Language = CId
+
+readPGF = PGF2.readPGF
+
+
+readLanguage = readCId
+showLanguage (CId s) = s
+
+
+abstractName gr = CId (PGF2.abstractName gr)
+
+
+categories gr = map CId (PGF2.categories gr)
+
+
+functions gr  = map CId (PGF2.functions gr)
+functionsByCat gr (CId c) = map CId (PGF2.functionsByCat gr c)
+
+type Tree = PGF2.Expr
+
+
+mkCId x = CId x
+wildCId = CId "_"
+showCId (CId x) = x
+readCId s = Just (CId s)
+
+
+pIdent :: RP.ReadP String
+pIdent = 
+  liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest)
+  `mplus`
+  do RP.char '\''
+     cs <- RP.many1 insideChar
+     RP.char '\''
+     return cs
+--  where
+insideChar = RP.readS_to_P $ \s ->
+  case s of
+    []             -> []
+    ('\\':'\\':cs) -> [('\\',cs)]
+    ('\\':'\'':cs) -> [('\'',cs)]
+    ('\\':cs)      -> []
+    ('\'':cs)      -> []
+    (c:cs)         -> [(c,cs)]
+
+isIdentFirst c =
+  (c == '_') ||
+  (c >= 'a' && c <= 'z') ||
+  (c >= 'A' && c <= 'Z') ||
+  (c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215')
+isIdentRest c = 
+  (c == '_') ||
+  (c == '\'') ||
+  (c >= '0' && c <= '9') ||
+  (c >= 'a' && c <= 'z') ||
+  (c >= 'A' && c <= 'Z') ||
+  (c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215')
+
+pExpr :: RP.ReadP PGF2.Expr
+pExpr =
+  RP.readS_to_P $ \str ->
+  unsafePerformIO $
+  withText str $ \c_str ->
+  alloca  $ \c_pos ->
+  withForeignPtr unmarshaller $ \u ->
+  mask_ $ do
+    c_expr <- pgf_read_expr_ex c_str c_pos u
+    if c_expr == castPtrToStablePtr nullPtr
+      then return []
+      else do expr <- deRefStablePtr c_expr
+              freeStablePtr c_expr
+              pos <- peek c_pos
+              size <- ((#peek PgfText, size) c_str) :: IO CSize
+              let c_text = castPtr c_str `plusPtr` (#offset PgfText, text)
+              s    <- peekUtf8CString pos (c_text `plusPtr` fromIntegral size)
+              return [(expr,s)]

src/runtime/haskell/PGF2.hsc

@@ -27,7 +27,7 @@ module PGF2 (-- * PGF
              functionType, functionIsConstructor, functionProbability,
 
              -- ** Expressions
-             Expr(..), Literal(..), showExpr, readExpr, pExpr, pIdent,
+             Expr(..), Literal(..), showExpr, readExpr,
              mkAbs,    unAbs,
              mkApp,    unApp, unapply,
              mkStr,    unStr,
@@ -892,12 +892,6 @@ readExpr str =
               freeStablePtr c_expr
               return (Just expr)
 
-pIdent :: ReadS String
-pIdent = error "TODO: pIdent"
-
-pExpr :: ReadS Expr
-pExpr = error "TODO: pExpr"
-
 -- | renders a type as a 'String'. The list
 -- of identifiers is the list of all free variables
 -- in the type in order reverse to the order

src/runtime/haskell/PGF2/FFI.hsc

@@ -73,6 +73,8 @@ foreign import ccall "pgf_print_expr"
 foreign import ccall "pgf_read_expr"
   pgf_read_expr :: Ptr PgfText -> Ptr PgfUnmarshaller -> IO (StablePtr Expr)
 
+foreign import ccall pgf_read_expr_ex :: Ptr PgfText -> Ptr CString -> Ptr PgfUnmarshaller -> IO (StablePtr Expr)
+
 foreign import ccall "pgf_print_type"
   pgf_print_type :: StablePtr Type -> Ptr PgfPrintContext -> CInt -> Ptr PgfMarshaller -> IO (Ptr PgfText)
 
@@ -137,20 +139,10 @@ foreign import ccall pgf_set_abstract_flag :: Ptr PgfDB -> Ptr PgfRevision -> Pt
 -- Texts
 
 peekText :: Ptr PgfText -> IO String
-peekText ptr =
+peekText ptr = do
-  alloca $ \pptr -> do
+  size <- ((#peek PgfText, size) ptr) :: IO CSize
-    size <- ((#peek PgfText, size) ptr) :: IO CSize
+  let c_text = castPtr ptr `plusPtr` (#offset PgfText, text)
-    let c_text = castPtr ptr `plusPtr` (#offset PgfText, text)
+  peekUtf8CString c_text (c_text `plusPtr` fromIntegral size)
-    poke pptr c_text
-    decode pptr (c_text `plusPtr` fromIntegral size)
-  where
-    decode pptr end = do
-      ptr <- peek pptr
-      if ptr >= end
-        then return []
-        else do x <- pgf_utf8_decode pptr
-                cs <- decode pptr end
-                return (((toEnum . fromEnum) x) : cs)
 
 newTextEx :: Int -> String -> IO (Ptr a)
 newTextEx offs s = do
@@ -180,6 +172,19 @@ withText s fn =
   where
     size = utf8Length s
 
+peekUtf8CString c_start c_end =
+  alloca $ \pptr -> do
+    poke pptr c_start
+    decode pptr c_end
+  where
+    decode pptr end = do
+      ptr <- peek pptr
+      if ptr >= end
+        then return []
+        else do x <- pgf_utf8_decode pptr
+                cs <- decode pptr end
+                return (((toEnum . fromEnum) x) : cs)
+
 pokeUtf8CString s ptr =
   alloca $ \pptr ->
     poke pptr ptr >> encode s pptr