summaryrefslogtreecommitdiff
path: root/src/runtime/haskell-bind
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/haskell-bind')
-rw-r--r--src/runtime/haskell-bind/PGF2.hsc58
-rw-r--r--src/runtime/haskell-bind/PGF2/Expr.hsc97
-rw-r--r--src/runtime/haskell-bind/PGF2/FFI.hs19
-rw-r--r--src/runtime/haskell-bind/pgf2-bind.cabal2
4 files changed, 55 insertions, 121 deletions
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 5d0484c1e..a368d9ccd 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -38,7 +38,9 @@ module PGF2 (-- * PGF
mkFloat,unFloat,
mkMeta,unMeta,
-- ** Types
- Type(..), Hypo, BindType(..), startCat, showType,
+ Type, Hypo, BindType(..), startCat,
+ readType, showType,
+ mkType, unType,
-- * Concrete syntax
ConcName,Concr,languages,
@@ -69,6 +71,7 @@ import Control.Monad(forM_)
import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO)
import Text.PrettyPrint
import PGF2.Expr
+import PGF2.Type
import PGF2.FFI
import Foreign hiding ( Pool, newPool, unsafePerformIO )
@@ -141,13 +144,12 @@ languages p =
-- all abstract syntax expressions of the given type.
-- The expressions are ordered by their probability.
generateAll :: PGF -> Type -> [(Expr,Float)]
-generateAll p (DTyp _ cat _) =
+generateAll p (Type ctype _) =
unsafePerformIO $
do genPl <- gu_new_pool
exprPl <- gu_new_pool
- cat <- newUtf8CString cat genPl
exn <- gu_new_exn genPl
- enum <- pgf_generate_all (pgf p) cat exn genPl exprPl
+ enum <- pgf_generate_all (pgf p) ctype exn genPl exprPl
genFPl <- newForeignPtr gu_pool_finalizer genPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
fromPgfExprEnum enum genFPl (p,exprFPl)
@@ -164,9 +166,9 @@ abstractName p = unsafePerformIO (peekUtf8CString =<< pgf_abstract_name (pgf p))
-- definition is just for convenience.
startCat :: PGF -> Type
startCat p = unsafePerformIO $ do
- cat <- pgf_start_cat (pgf p)
- cat <- peekUtf8CString cat
- return (DTyp [] cat [])
+ typPl <- gu_new_pool
+ c_type <- pgf_start_cat (pgf p) typPl
+ return (Type c_type typPl)
loadConcr :: Concr -> FilePath -> IO ()
loadConcr c fpath =
@@ -199,36 +201,7 @@ functionType p fn =
c_type <- pgf_function_type (pgf p) c_fn
if c_type == nullPtr
then throwIO (PGFError ("Function '"++fn++"' is not defined"))
- else peekType c_type
- where
- peekType c_type = do
- cid <- (#peek PgfType, cid) c_type >>= peekUtf8CString
- c_hypos <- (#peek PgfType, hypos) c_type
- n_hypos <- (#peek GuSeq, len) c_hypos
- hs <- peekHypos (c_hypos `plusPtr` (#offset GuSeq, data)) 0 n_hypos
- n_exprs <- (#peek PgfType, n_exprs) c_type
- es <- peekExprs (c_type `plusPtr` (#offset PgfType, exprs)) 0 n_exprs
- return (DTyp hs cid es)
-
- peekHypos :: Ptr a -> Int -> Int -> IO [Hypo]
- peekHypos c_hypo i n
- | i < n = do cid <- (#peek PgfHypo, cid) c_hypo >>= peekUtf8CString
- ty <- (#peek PgfHypo, type) c_hypo >>= peekType
- bt <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo)
- hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n
- return ((bt,cid,ty) : hs)
- | otherwise = return []
-
- toBindType :: CInt -> BindType
- toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
- toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit
-
- peekExprs ptr i n
- | i < n = do e <- peekElemOff ptr i
- es <- peekExprs ptr (i+1) n
- return (Expr e p : es)
- | otherwise = return []
-
+ else return (Type c_type (pgfMaster p))
-----------------------------------------------------------------------------
-- Graphviz
@@ -326,15 +299,14 @@ parseWithHeuristics :: Concr -- ^ the language with which we parse
-- If a literal has been recognized then the output should
-- be Just (expr,probability,end_offset)
-> Either String [(Expr,Float)]
-parseWithHeuristics lang (DTyp _ cat _) sent heuristic callbacks =
+parseWithHeuristics lang (Type ctype _) sent heuristic callbacks =
unsafePerformIO $
do exprPl <- gu_new_pool
parsePl <- gu_new_pool
exn <- gu_new_exn parsePl
- cat <- newUtf8CString cat parsePl
sent <- newUtf8CString sent parsePl
callbacks_map <- mkCallbacksMap (concr lang) callbacks parsePl
- enum <- pgf_parse_with_heuristics (concr lang) cat sent heuristic callbacks_map exn parsePl exprPl
+ enum <- pgf_parse_with_heuristics (concr lang) ctype sent heuristic callbacks_map exn parsePl exprPl
failed <- gu_exn_is_raised exn
if failed
then do is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError
@@ -574,7 +546,7 @@ showBracketedString :: BracketedString -> String
showBracketedString = render . ppBracketedString
ppBracketedString (Leaf t) = text t
-ppBracketedString (Bracket cat fid index _ bss) = parens (ppCId cat <> colon <> int fid <+> hsep (map ppBracketedString bss))
+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]
@@ -657,7 +629,7 @@ functionsByCat p cat =
-- with the \'cat\' keyword.
categories :: PGF -> [Cat]
categories pgf = -- !!! quick hack
- nub [cat | f<-functions pgf, let DTyp _ cat _=functionType pgf f]
+ nub [cat | f<-functions pgf, let (_, cat, _) = unType (functionType pgf f)]
categoryContext :: PGF -> Cat -> Maybe [Hypo]
categoryContext pgf cat = Nothing -- !!! not implemented yet TODO
@@ -729,7 +701,7 @@ nerc pgf (lang,concr) sentence lin_idx offset =
Just (y,xs') -> (y:ys,xs'')
where (ys,xs'') = consume munch xs'
- functionCat f = case functionType pgf f of DTyp _ cat _ -> cat
+ functionCat f = case unType (functionType pgf f) of (_,cat,_) -> cat
-- | Callback to parse arbitrary words as chunks (from
-- ../java/org/grammaticalframework/pgf/UnknownLiteralCallback.java)
diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc
index c18e97a13..84559e5a0 100644
--- a/src/runtime/haskell-bind/PGF2/Expr.hsc
+++ b/src/runtime/haskell-bind/PGF2/Expr.hsc
@@ -6,20 +6,22 @@ module PGF2.Expr where
import System.IO.Unsafe(unsafePerformIO)
import Foreign hiding (unsafePerformIO)
import Foreign.C
-import qualified Text.PrettyPrint as PP
import PGF2.FFI
-import Data.List(mapAccumL)
-- | An data type that represents
-- identifiers for functions and categories in PGF.
type CId = String
-ppCId = PP.text
wildCId = "_" :: CId
type Cat = CId -- ^ Name of syntactic category
type Fun = CId -- ^ Name of function
+data BindType =
+ Explicit
+ | Implicit
+ deriving Show
+
-----------------------------------------------------------------------------
-- Expressions
@@ -177,19 +179,16 @@ readExpr str =
unsafePerformIO $
do exprPl <- gu_new_pool
withGuPool $ \tmpPl ->
- withCString str $ \c_str ->
- do guin <- gu_string_in c_str tmpPl
- exn <- gu_new_exn tmpPl
- c_expr <- pgf_read_expr guin exprPl exn
- status <- gu_exn_is_raised exn
- if (not status && c_expr /= nullPtr)
- then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
- return $ Just (Expr c_expr exprFPl)
- else do gu_pool_free exprPl
- return Nothing
-
-ppExpr :: Int -> [CId] -> Expr -> PP.Doc
-ppExpr d xs e = ppParens (d>0) (PP.text (showExpr xs e)) -- just a quick hack !!!
+ 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
+ status <- gu_exn_is_raised exn
+ if (not status && c_expr /= nullPtr)
+ then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
+ return $ Just (Expr c_expr exprFPl)
+ else do gu_pool_free exprPl
+ return Nothing
-- | renders an expression as a 'String'. The list
-- of identifiers is the list of all free variables
@@ -200,62 +199,16 @@ showExpr scope e =
unsafePerformIO $
withGuPool $ \tmpPl ->
do (sb,out) <- newOut tmpPl
- let printCtxt = nullPtr
+ printCtxt <- newPrintCtxt scope tmpPl
exn <- gu_new_exn tmpPl
pgf_print_expr (expr e) printCtxt 1 out exn
s <- gu_string_buf_freeze sb tmpPl
- peekCString s
-
-
------------------------------------------------------------------------------
--- Types
-
-data Type =
- DTyp [Hypo] CId [Expr]
- deriving Show
-
-data BindType =
- Explicit
- | Implicit
- deriving Show
-
--- | 'Hypo' represents a hypothesis in a type i.e. in the type A -> B, A is the hypothesis
-type Hypo = (BindType,CId,Type)
-
--- | renders type as 'String'.
-showType :: Type -> String
-showType = PP.render . ppType 0 []
-
-ppType :: Int -> [CId] -> Type -> PP.Doc
-ppType d scope (DTyp hyps cat args)
- | null hyps = ppRes scope cat args
- | otherwise = let (scope',hdocs) = mapAccumL (ppHypo 1) scope hyps
- in ppParens (d > 0) (foldr (\hdoc doc -> hdoc PP.<+> PP.text "->" PP.<+> doc) (ppRes scope cat args) hdocs)
- where
- ppRes scope cat es
- | null es = ppCId cat
- | otherwise = ppParens (d > 3) (ppCId cat PP.<+> PP.hsep (map (ppExpr 4 scope) es))
-
-ppHypo :: Int -> [CId]-> (BindType,CId,Type) -> ([CId],PP.Doc)
-ppHypo d scope (Explicit,x,typ) =
- if x == wildCId
- then (scope, ppType d scope typ)
- else let y = freshName x scope
- in (y:scope, PP.parens (ppCId x PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
-ppHypo d scope (Implicit,x,typ) =
- if x == wildCId
- then (scope,PP.parens (PP.braces (ppCId x) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
- else let y = freshName x scope
- in (y:scope,PP.parens (PP.braces (ppCId x) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
-
-freshName :: CId -> [CId] -> CId
-freshName x xs0 = loop 1 x
- where
- xs = wildCId : xs0
-
- loop i y
- | elem y xs = loop (i+1) (x++show i)
- | otherwise = y
-
-ppParens True = PP.parens
-ppParens False = id
+ peekUtf8CString s
+
+newPrintCtxt :: [String] -> Ptr GuPool -> IO (Ptr PgfPrintContext)
+newPrintCtxt [] pool = return nullPtr
+newPrintCtxt (x:xs) pool = do
+ pctxt <- gu_malloc pool (#size PgfPrintContext)
+ newUtf8CString x pool >>= (#poke PgfPrintContext, name) pctxt
+ newPrintCtxt xs pool >>= (#poke PgfPrintContext, next) pctxt
+ return pctxt
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs
index 9051b1465..949c46471 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hs
+++ b/src/runtime/haskell-bind/PGF2/FFI.hs
@@ -85,6 +85,9 @@ foreign import ccall unsafe "gu/utf8.h gu_utf8_decode"
foreign import ccall unsafe "gu/utf8.h gu_utf8_encode"
gu_utf8_encode :: Int32 -> Ptr CString -> IO ()
+foreign import ccall unsafe "gu/seq.h gu_make_seq"
+ gu_make_seq :: CInt -> CInt -> Ptr GuPool -> IO (Ptr GuSeq)
+
withGuPool :: (Ptr GuPool -> IO a) -> IO a
withGuPool f = bracket gu_new_pool gu_pool_free f
@@ -133,7 +136,7 @@ data PgfExprProb
data PgfFullFormEntry
data PgfMorphoCallback
data PgfPrintContext
-data PgfType
+type PgfType = Ptr ()
data PgfCallbacksMap
data PgfOracleCallback
data PgfCncTree
@@ -166,7 +169,7 @@ foreign import ccall "pgf/pgf.h pgf_iter_categories"
pgf_iter_categories :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_start_cat"
- pgf_start_cat :: Ptr PgfPGF -> IO CString
+ pgf_start_cat :: Ptr PgfPGF -> Ptr GuPool -> IO PgfType
foreign import ccall "pgf/pgf.h pgf_iter_functions"
pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
@@ -175,7 +178,7 @@ foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat"
pgf_iter_functions_by_cat :: Ptr PgfPGF -> CString -> Ptr GuMapItor -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_function_type"
- pgf_function_type :: Ptr PgfPGF -> CString -> IO (Ptr PgfType)
+ pgf_function_type :: Ptr PgfPGF -> CString -> IO PgfType
foreign import ccall "pgf/pgf.h pgf_print_name"
pgf_print_name :: Ptr PgfConcr -> CString -> IO CString
@@ -199,7 +202,7 @@ foreign import ccall "pgf/pgf.h pgf_align_words"
pgf_align_words :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuSeq)
foreign import ccall "pgf/pgf.h pgf_parse_with_heuristics"
- pgf_parse_with_heuristics :: Ptr PgfConcr -> CString -> CString -> Double -> Ptr PgfCallbacksMap -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
+ pgf_parse_with_heuristics :: Ptr PgfConcr -> PgfType -> CString -> Double -> Ptr PgfCallbacksMap -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
type LiteralMatchCallback = CInt -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb)
@@ -293,8 +296,11 @@ foreign import ccall "pgf/expr.h pgf_print_expr"
foreign import ccall "pgf/expr.h pgf_print_expr_tuple"
pgf_print_expr_tuple :: CInt -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO ()
+foreign import ccall "pgf/expr.h pgf_print_type"
+ pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
+
foreign import ccall "pgf/pgf.h pgf_generate_all"
- pgf_generate_all :: Ptr PgfPGF -> CString -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
+ pgf_generate_all :: Ptr PgfPGF -> PgfType -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
foreign import ccall "pgf/pgf.h pgf_print"
pgf_print :: Ptr PgfPGF -> Ptr GuOut -> Ptr GuExn -> IO ()
@@ -308,6 +314,9 @@ foreign import ccall "pgf/expr.h pgf_read_expr_tuple"
foreign import ccall "pgf/expr.h pgf_read_expr_matrix"
pgf_read_expr_matrix :: Ptr GuIn -> CInt -> 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
+
foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree"
pgf_graphviz_abstract_tree :: Ptr PgfPGF -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO ()
diff --git a/src/runtime/haskell-bind/pgf2-bind.cabal b/src/runtime/haskell-bind/pgf2-bind.cabal
index 4e60264a5..dfde308b9 100644
--- a/src/runtime/haskell-bind/pgf2-bind.cabal
+++ b/src/runtime/haskell-bind/pgf2-bind.cabal
@@ -18,7 +18,7 @@ cabal-version: >=1.10
library
exposed-modules: PGF2, SG
- other-modules: PGF2.FFI, PGF2.Expr, SG.FFI
+ other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI
build-depends: base >=4.3, bytestring >=0.9,
containers, pretty
-- hs-source-dirs:
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 21:17:43 +0000