forked from GitHub/gf-core
bring the Haskell binding a bit closer to the pure Haskell API
This commit is contained in:
krasimir
@@ -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)
|
||||
|
||||
@@ -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
|
||||
peekUtf8CString 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
|
||||
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
|
||||
|
||||
@@ -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 ()
|
||||
|
||||
|
||||
@@ -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:
|
||||
|
||||
Reference in New Issue
Block a user