From 22f62be511d28b4e4b5cca32477fbe8e988b69ea Mon Sep 17 00:00:00 2001 From: krangelov Date: Tue, 14 Sep 2021 09:34:00 +0200 Subject: [PATCH] added PGF(pIdent,pExpr) --- src/compiler/GF/Command/Parse.hs | 10 +-- src/runtime/c/pgf/expr.cxx | 12 ++-- src/runtime/c/pgf/expr.h | 5 +- src/runtime/c/pgf/pgf.cxx | 13 +++- src/runtime/c/pgf/pgf.h | 3 + src/runtime/haskell/PGF.hs | 56 --------------- src/runtime/haskell/PGF.hsc | 117 +++++++++++++++++++++++++++++++ src/runtime/haskell/PGF2.hsc | 8 +-- src/runtime/haskell/PGF2/FFI.hsc | 33 +++++---- 9 files changed, 166 insertions(+), 91 deletions(-) delete mode 100644 src/runtime/haskell/PGF.hs create mode 100644 src/runtime/haskell/PGF.hsc diff --git a/src/compiler/GF/Command/Parse.hs b/src/compiler/GF/Command/Parse.hs index e7b36e239..9ead12e7e 100644 --- a/src/compiler/GF/Command/Parse.hs +++ b/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 diff --git a/src/runtime/c/pgf/expr.cxx b/src/runtime/c/pgf/expr.cxx index b6b3919fe..dc7714ea3 100644 --- a/src/runtime/c/pgf/expr.cxx +++ b/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) { diff --git a/src/runtime/c/pgf/expr.h b/src/runtime/c/pgf/expr.h index bcc45bef4..e277f421c 100644 --- a/src/runtime/c/pgf/expr.h +++ b/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; diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 71ab27f4f..42e40ee03 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -418,8 +418,8 @@ PgfText *pgf_print_expr(PgfExpr e, return printer.get_text(); } -PGF_API PgfExpr -pgf_read_expr(PgfText *input, PgfUnmarshaller *u) +PGF_API +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, diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index d9cec6e9d..8af87bbfc 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/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, diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs deleted file mode 100644 index 7e685d71a..000000000 --- a/src/runtime/haskell/PGF.hs +++ /dev/null @@ -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) diff --git a/src/runtime/haskell/PGF.hsc b/src/runtime/haskell/PGF.hsc new file mode 100644 index 000000000..d75b7482c --- /dev/null +++ b/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 + +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)] diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 758ae39a6..f2a15eab1 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/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 diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index c2b477a6b..767be72a4 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/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 = - alloca $ \pptr -> do - size <- ((#peek PgfText, size) ptr) :: IO CSize - let c_text = castPtr ptr `plusPtr` (#offset PgfText, text) - 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) +peekText ptr = do + size <- ((#peek PgfText, size) ptr) :: IO CSize + let c_text = castPtr ptr `plusPtr` (#offset PgfText, text) + peekUtf8CString c_text (c_text `plusPtr` fromIntegral size) 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