GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-20 08:32:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into c-runtime

Browse Source
This commit is contained in:
krangelov
2021-07-30 11:20:04 +02:00
parent eece3e86b3 265f08d6ee
commit 155657709a
211 changed files with 7161 additions and 58549 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
src/runtime/haskell/CHANGELOG.md Normal file
View File

@@ -0,0 +1,22 @@
## 1.3.0
- Add completion support.
## 1.2.1
- Remove deprecated `pgf_print_expr_tuple`.
- Added an API for cloning expressions/types/literals.
## 1.2.0
- Stop `pgf-shell` from being built by default.
- parseToChart also returns the category.
- bugfix in bracketedLinearize.
## 1.1.0
- Remove SG library.
## 1.0.0
- Everything up until 2020-07-11.

10
src/runtime/haskell/HACKAGE.md Normal file
View File

@@ -0,0 +1,10 @@
# Instructions for uploading to Hackage
You will need a Hackage account for steps 4 & 5.
1. Bump the version number in `pgf2.cabal`
2. Add details in `CHANGELOG.md`
3. Run `stack sdist` (or `cabal sdist`)
4. Visit `https://hackage.haskell.org/upload` and upload the file `./.stack-work/dist/x86_64-osx/Cabal-2.2.0.1/pgf2-x.y.z.tar.gz` (or Cabal equivalent)
5. If successful, upload documentation with `./stack-haddock-upload.sh pgf2 x.y.z` (compilation on Hackage's servers will fail because of missing C libraries)
6. Commit and push to this repository (`gf-core`)

165
src/runtime/haskell/LICENSE Normal file
View File

@@ -0,0 +1,165 @@
GNU LESSER GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
This version of the GNU Lesser General Public License incorporates
the terms and conditions of version 3 of the GNU General Public
License, supplemented by the additional permissions listed below.
0. Additional Definitions.
As used herein, "this License" refers to version 3 of the GNU Lesser
General Public License, and the "GNU GPL" refers to version 3 of the GNU
General Public License.
"The Library" refers to a covered work governed by this License,
other than an Application or a Combined Work as defined below.
An "Application" is any work that makes use of an interface provided
by the Library, but which is not otherwise based on the Library.
Defining a subclass of a class defined by the Library is deemed a mode
of using an interface provided by the Library.
A "Combined Work" is a work produced by combining or linking an
Application with the Library. The particular version of the Library
with which the Combined Work was made is also called the "Linked
Version".
The "Minimal Corresponding Source" for a Combined Work means the
Corresponding Source for the Combined Work, excluding any source code
for portions of the Combined Work that, considered in isolation, are
based on the Application, and not on the Linked Version.
The "Corresponding Application Code" for a Combined Work means the
object code and/or source code for the Application, including any data
and utility programs needed for reproducing the Combined Work from the
Application, but excluding the System Libraries of the Combined Work.
1. Exception to Section 3 of the GNU GPL.
You may convey a covered work under sections 3 and 4 of this License
without being bound by section 3 of the GNU GPL.
2. Conveying Modified Versions.
If you modify a copy of the Library, and, in your modifications, a
facility refers to a function or data to be supplied by an Application
that uses the facility (other than as an argument passed when the
facility is invoked), then you may convey a copy of the modified
version:
a) under this License, provided that you make a good faith effort to
ensure that, in the event an Application does not supply the
function or data, the facility still operates, and performs
whatever part of its purpose remains meaningful, or
b) under the GNU GPL, with none of the additional permissions of
this License applicable to that copy.
3. Object Code Incorporating Material from Library Header Files.
The object code form of an Application may incorporate material from
a header file that is part of the Library. You may convey such object
code under terms of your choice, provided that, if the incorporated
material is not limited to numerical parameters, data structure
layouts and accessors, or small macros, inline functions and templates
(ten or fewer lines in length), you do both of the following:
a) Give prominent notice with each copy of the object code that the
Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the object code with a copy of the GNU GPL and this license
document.
4. Combined Works.
You may convey a Combined Work under terms of your choice that,
taken together, effectively do not restrict modification of the
portions of the Library contained in the Combined Work and reverse
engineering for debugging such modifications, if you also do each of
the following:
a) Give prominent notice with each copy of the Combined Work that
the Library is used in it and that the Library and its use are
covered by this License.
b) Accompany the Combined Work with a copy of the GNU GPL and this license
document.
c) For a Combined Work that displays copyright notices during
execution, include the copyright notice for the Library among
these notices, as well as a reference directing the user to the
copies of the GNU GPL and this license document.
d) Do one of the following:
0) Convey the Minimal Corresponding Source under the terms of this
License, and the Corresponding Application Code in a form
suitable for, and under terms that permit, the user to
recombine or relink the Application with a modified version of
the Linked Version to produce a modified Combined Work, in the
manner specified by section 6 of the GNU GPL for conveying
Corresponding Source.
1) Use a suitable shared library mechanism for linking with the
Library. A suitable mechanism is one that (a) uses at run time
a copy of the Library already present on the user's computer
system, and (b) will operate properly with a modified version
of the Library that is interface-compatible with the Linked
Version.
e) Provide Installation Information, but only if you would otherwise
be required to provide such information under section 6 of the
GNU GPL, and only to the extent that such information is
necessary to install and execute a modified version of the
Combined Work produced by recombining or relinking the
Application with a modified version of the Linked Version. (If
you use option 4d0, the Installation Information must accompany
the Minimal Corresponding Source and Corresponding Application
Code. If you use option 4d1, you must provide the Installation
Information in the manner specified by section 6 of the GNU GPL
for conveying Corresponding Source.)
5. Combined Libraries.
You may place library facilities that are a work based on the
Library side by side in a single library together with other library
facilities that are not Applications and are not covered by this
License, and convey such a combined library under terms of your
choice, if you do both of the following:
a) Accompany the combined library with a copy of the same work based
on the Library, uncombined with any other library facilities,
conveyed under the terms of this License.
b) Give prominent notice with the combined library that part of it
is a work based on the Library, and explaining where to find the
accompanying uncombined form of the same work.
6. Revised Versions of the GNU Lesser General Public License.
The Free Software Foundation may publish revised and/or new versions
of the GNU Lesser General Public License from time to time. Such new
versions will be similar in spirit to the present version, but may
differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the
Library as you received it specifies that a certain numbered version
of the GNU Lesser General Public License "or any later version"
applies to it, you have the option of following the terms and
conditions either of that published version or of any later version
published by the Free Software Foundation. If the Library as you
received it does not specify a version number of the GNU Lesser
General Public License, you may choose any version of the GNU Lesser
General Public License ever published by the Free Software Foundation.
If the Library as you received it specifies that a proxy can decide
whether future versions of the GNU Lesser General Public License shall
apply, that proxy's public statement of acceptance of any version is
permanent authorization for you to choose that version for the
Library.

2
src/runtime/haskell/PGF.hs
View File

@@ -158,7 +158,7 @@ parse_ pgf lang cat dp s =
PGF2.ParseIncomplete -> (ParseIncomplete, PGF2.Leaf s)
complete pgf lang cat s prefix =
let compls = Map.fromListWith (++) [(tok,[CId fun]) | (tok,_,fun,_) <- PGF2.complete (lookConcr pgf lang) cat s prefix]
let compls = Map.fromListWith (++) [(tok,[CId fun]) | PGF2.ParseOk res <- [PGF2.complete (lookConcr pgf lang) cat s prefix], (tok,_,fun,_) <- res]
in (PGF2.Leaf [],s,compls)
hasLinearization pgf lang (CId f) = PGF2.hasLinearization (lookConcr pgf lang) f

536
src/runtime/haskell/PGF2.hsc
View File

@@ -15,6 +15,7 @@
#include <pgf/pgf.h>
#include <pgf/linearizer.h>
#include <pgf/data.h>
#include <gu/enum.h>
#include <gu/exn.h>
@@ -38,30 +39,28 @@ module PGF2 (-- * PGF
mkMeta,unMeta,
exprHash, exprSize, exprFunctions, exprSubstitute,
treeProbability,
-- ** Types
Type, Hypo, BindType(..), startCat,
readType, showType, showContext,
mkType, unType,
-- ** Type checking
-- | Dynamically-built expressions should always be type-checked before using in other functions,
-- as the exceptions thrown by using invalid expressions may not catchable.
checkExpr, inferExpr, checkType,
-- ** Computing
compute,
-- * Concrete syntax
ConcName,Concr,languages,concreteName,languageCode,
-- ** Linearization
linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize,
FId, LIndex, BracketedString(..), showBracketedString, flattenBracketedString,
printName,
linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize,bracketedLinearizeAll,
FId, BracketedString(..), showBracketedString, flattenBracketedString,
printName, categoryFields,
alignWords, gizaAlignment,
-- ** Parsing
ParseOutput(..), parse, parseWithHeuristics, complete,
ParseOutput(..), parse, parseWithHeuristics,
parseToChart, PArg(..),
complete,
-- ** Sentence Lookup
lookupSentence,
@@ -71,6 +70,7 @@ module PGF2 (-- * PGF
-- ** Morphological Analysis
MorphoAnalysis, lookupMorpho, lookupCohorts, fullFormLexicon,
filterBest, filterLongest,
-- ** Visualizations
GraphvizOptions(..), graphvizDefaults,
graphvizAbstractTree, graphvizParseTree,
@@ -88,11 +88,12 @@ module PGF2 (-- * PGF
readProbabilitiesFromFile
) where
import Prelude hiding (fromEnum)
import Prelude hiding (fromEnum,(<>))
import Control.Exception(Exception,throwIO)
import Control.Monad(forM_)
import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO)
import System.Random
import System.IO(fixIO)
import Text.PrettyPrint
import PGF2.Expr
import PGF2.Type
@@ -103,12 +104,12 @@ import Foreign.C
import Data.Typeable
import qualified Data.Map as Map
import Data.IORef
import Data.Char(isUpper,isSpace)
import Data.Char(isUpper,isSpace,isPunctuation)
import Data.List(isSuffixOf,maximumBy,nub,mapAccumL,intersperse,groupBy,find)
import Data.Maybe(fromMaybe)
import Data.Function(on)
import Data.Maybe(maybe)
-----------------------------------------------------------------------
-- Functions that take a PGF.
-- PGF has many Concrs.
@@ -188,7 +189,7 @@ languageCode c = unsafePerformIO $ do
else fmap Just (peekUtf8CString c_code)
-- | Generates an exhaustive possibly infinite list of
-- all abstract syntax expressions of the given type.
-- all abstract syntax expressions of the given type.
-- The expressions are ordered by their probability.
generateAll :: PGF -> Type -> [(Expr,Float)]
generateAll p (Type ctype _) =
@@ -450,6 +451,7 @@ graphvizParseTree c opts e =
c_opts <- newGraphvizOptions tmpPl opts
pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn
touchExpr e
touchConcr c
s <- gu_string_buf_freeze sb tmpPl
peekUtf8CString s
@@ -915,21 +917,21 @@ newGraphvizOptions pool opts = do
-- Functions using Concr
-- Morpho analyses, parsing & linearization
-- | This triple is returned by all functions that deal with
-- | This triple is returned by all functions that deal with
-- the grammar's lexicon. Its first element is the name of an abstract
-- lexical function which can produce a given word or
-- lexical function which can produce a given word or
-- a multiword expression (i.e. this is the lemma).
-- After that follows a string which describes
-- After that follows a string which describes
-- the particular inflection form.
--
-- The last element is a logarithm from the
-- the probability of the function. The probability is not
-- the probability of the function. The probability is not
-- conditionalized on the category of the function. This makes it
-- possible to compare the likelihood of two functions even if they
-- have different types.
-- have different types.
type MorphoAnalysis = (Fun,String,Float)
-- | 'lookupMorpho' takes a string which must be a single word or
-- | 'lookupMorpho' takes a string which must be a single word or
-- a multiword expression. It then computes the list of all possible
-- morphological analyses.
lookupMorpho :: Concr -> String -> [MorphoAnalysis]
@@ -954,7 +956,7 @@ lookupMorpho (Concr concr master) sent =
-- The list is sorted first by the @start@ position and after than
-- by the @end@ position. This can be used for instance if you want to
-- filter only the longest matches.
lookupCohorts :: Concr -> String -> [(Int,[MorphoAnalysis],Int)]
lookupCohorts :: Concr -> String -> [(Int,String,[MorphoAnalysis],Int)]
lookupCohorts lang@(Concr concr master) sent =
unsafePerformIO $
do pl <- gu_new_pool
@@ -965,9 +967,9 @@ lookupCohorts lang@(Concr concr master) sent =
c_sent <- newUtf8CString sent pl
enum <- pgf_lookup_cohorts concr c_sent cback pl nullPtr
fpl <- newForeignPtr gu_pool_finalizer pl
fromCohortRange enum fpl fptr ref
fromCohortRange enum fpl fptr 0 sent ref
where
fromCohortRange enum fpl fptr ref =
fromCohortRange enum fpl fptr i sent ref =
allocaBytes (#size PgfCohortRange) $ \ptr ->
withForeignPtr fpl $ \pl ->
do gu_enum_next enum ptr pl
@@ -981,8 +983,80 @@ lookupCohorts lang@(Concr concr master) sent =
end <- (#peek PgfCohortRange, end.pos) ptr
ans <- readIORef ref
writeIORef ref []
cohs <- unsafeInterleaveIO (fromCohortRange enum fpl fptr ref)
return ((start,ans,end):cohs)
let sent' = drop (start-i) sent
tok = take (end-start) sent'
cohs <- unsafeInterleaveIO (fromCohortRange enum fpl fptr start sent' ref)
return ((start,tok,ans,end):cohs)
filterBest :: [(Int,String,[MorphoAnalysis],Int)] -> [(Int,String,[MorphoAnalysis],Int)]
filterBest ans =
reverse (iterate (maxBound :: Int) [(0,0,[],ans)] [] [])
where
iterate v0 [] [] res = res
iterate v0 [] new res = iterate v0 new [] res
iterate v0 ((_,v,conf, []):old) new res =
case compare v0 v of
LT -> res
EQ -> iterate v0 old new (merge conf res)
GT -> iterate v old new conf
iterate v0 ((_,v,conf,an:ans):old) new res = iterate v0 old (insert (v+valueOf an) conf an ans [] new) res
valueOf (_,_,[],_) = 2
valueOf _ = 1
insert v conf an@(start,_,_,end) ans l_new [] =
match start v conf ans ((end,v,comb conf an,filter end ans):l_new) []
insert v conf an@(start,_,_,end) ans l_new (new@(end0,v0,conf0,ans0):r_new) =
case compare end0 end of
LT -> insert v conf an ans (new:l_new) r_new
EQ -> case compare v0 v of
LT -> match start v conf ans ((end,v, conf0,ans0): l_new) r_new
EQ -> match start v conf ans ((end,v,merge (comb conf an) conf0,ans0): l_new) r_new
GT -> match start v conf ans ((end,v,comb conf an, ans0): l_new) r_new
GT -> match start v conf ans ((end,v,comb conf an, filter end ans):new:l_new) r_new
match start0 v conf (an@(start,_,_,end):ans) l_new r_new
| start0 == start = insert v conf an ans l_new r_new
match start0 v conf ans l_new r_new = revOn l_new r_new
comb ((start0,w0,an0,end0):conf) (start,w,an,end)
| end0 == start && (unk w0 an0 || unk w an) = (start0,w0++w,[],end):conf
comb conf an = an:conf
filter end [] = []
filter end (next@(start,_,_,_):ans)
| end <= start = next:ans
| otherwise = filter end ans
revOn [] ys = ys
revOn (x:xs) ys = revOn xs (x:ys)
merge [] ans = ans
merge ans [] = ans
merge (an1@(start1,_,_,end1):ans1) (an2@(start2,_,_,end2):ans2) =
case compare (start1,end1) (start2,end2) of
GT -> an1 : merge ans1 (an2:ans2)
EQ -> an1 : merge ans1 ans2
LT -> an2 : merge (an1:ans1) ans2
filterLongest :: [(Int,String,[MorphoAnalysis],Int)] -> [(Int,String,[MorphoAnalysis],Int)]
filterLongest [] = []
filterLongest (an:ans) = longest an ans
where
longest prev [] = [prev]
longest prev@(start0,_,_,end0) (next@(start,_,_,end):ans)
| start0 == start = longest next ans
| otherwise = filter prev (next:ans)
filter prev [] = [prev]
filter prev@(start0,w0,an0,end0) (next@(start,w,an,end):ans)
| end0 == start && (unk w0 an0 || unk w an)
= filter (start0,w0++w,[],end) ans
| end0 <= start = prev : longest next ans
| otherwise = filter prev ans
unk w [] | any (not . isPunctuation) w = True
unk _ _ = False
fullFormLexicon :: Concr -> [(String, [MorphoAnalysis])]
fullFormLexicon lang =
@@ -1020,32 +1094,32 @@ getAnalysis ref self c_lemma c_anal prob exn = do
writeIORef ref ((lemma, anal, prob):ans)
-- | This data type encodes the different outcomes which you could get from the parser.
data ParseOutput
data ParseOutput a
= ParseFailed Int String -- ^ The integer is the position in number of unicode characters where the parser failed.
-- The string is the token where the parser have failed.
| ParseOk [(Expr,Float)] -- ^ If the parsing and the type checking are successful we get a list of abstract syntax trees.
-- The list should be non-empty.
| ParseOk a -- ^ If the parsing and the type checking are successful
-- we get the abstract syntax trees as either a list or a chart.
| ParseIncomplete -- ^ The sentence is not complete.
parse :: Concr -> Type -> String -> ParseOutput
parse :: Concr -> Type -> String -> ParseOutput [(Expr,Float)]
parse lang ty sent = parseWithHeuristics lang ty sent (-1.0) []
parseWithHeuristics :: Concr -- ^ the language with which we parse
-> Type -- ^ the start category
-> String -- ^ the input sentence
-> Double -- ^ the heuristic factor.
-- A negative value tells the parser
-- to lookup up the default from
-> Double -- ^ the heuristic factor.
-- A negative value tells the parser
-- to lookup up the default from
-- the grammar flags
-> [(Cat, Int -> Int -> Maybe (Expr,Float,Int))]
-> [(Cat, String -> Int -> Maybe (Expr,Float,Int))]
-- ^ a list of callbacks for literal categories.
-- The arguments of the callback are:
-- the index of the constituent for the literal category;
-- the input sentence; the current offset in the sentence.
-- If a literal has been recognized then the output should
-- be Just (expr,probability,end_offset)
-> ParseOutput
parseWithHeuristics lang (Type ctype _) sent heuristic callbacks =
-> ParseOutput [(Expr,Float)]
parseWithHeuristics lang (Type ctype touchType) sent heuristic callbacks =
unsafePerformIO $
do exprPl <- gu_new_pool
parsePl <- gu_new_pool
@@ -1085,7 +1159,137 @@ parseWithHeuristics lang (Type ctype _) sent heuristic callbacks =
exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl)
return (ParseOk exprs)
mkCallbacksMap :: Ptr PgfConcr -> [(String, Int -> Int -> Maybe (Expr,Float,Int))] -> Ptr GuPool -> IO (Ptr PgfCallbacksMap)
parseToChart :: Concr -- ^ the language with which we parse
-> Type -- ^ the start category
-> String -- ^ the input sentence
-> Double -- ^ the heuristic factor.
-- A negative value tells the parser
-- to lookup up the default from
-- the grammar flags
-> [(Cat, String -> Int -> Maybe (Expr,Float,Int))]
-- ^ a list of callbacks for literal categories.
-- The arguments of the callback are:
-- the index of the constituent for the literal category;
-- the input sentence; the current offset in the sentence.
-- If a literal has been recognized then the output should
-- be Just (expr,probability,end_offset)
-> Int -- ^ the maximal number of roots
-> ParseOutput ([FId],Map.Map FId ([(Int,Int,String)],[(Expr,[PArg],Float)],Cat))
parseToChart lang (Type ctype touchType) sent heuristic callbacks roots =
unsafePerformIO $
withGuPool $ \parsePl -> do
do exn <- gu_new_exn parsePl
sent <- newUtf8CString sent parsePl
callbacks_map <- mkCallbacksMap (concr lang) callbacks parsePl
ps <- pgf_parse_to_chart (concr lang) ctype sent heuristic callbacks_map (fromIntegral roots) exn parsePl parsePl
touchType
failed <- gu_exn_is_raised exn
if failed
then do is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError
if is_parse_error
then do c_err <- (#peek GuExn, data.data) exn
c_incomplete <- (#peek PgfParseError, incomplete) c_err
if (c_incomplete :: CInt) == 0
then do c_offset <- (#peek PgfParseError, offset) c_err
token_ptr <- (#peek PgfParseError, token_ptr) c_err
token_len <- (#peek PgfParseError, token_len) c_err
tok <- peekUtf8CStringLen token_ptr token_len
touchConcr lang
return (ParseFailed (fromIntegral (c_offset :: CInt)) tok)
else do touchConcr lang
return ParseIncomplete
else do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
if is_exn
then do c_msg <- (#peek GuExn, data.data) exn
msg <- peekUtf8CString c_msg
touchConcr lang
throwIO (PGFError msg)
else do touchConcr lang
throwIO (PGFError "Parsing failed")
else do c_roots <- pgf_get_parse_roots ps parsePl
let get_range c_ccat = pgf_ccat_to_range ps c_ccat parsePl
c_len <- (#peek GuSeq, len) c_roots
chart <- peekCCats get_range Map.empty (c_len :: CSizeT) (c_roots `plusPtr` (#offset GuSeq, data))
touchConcr lang
return (ParseOk chart)
where
peekCCats get_range chart 0 ptr = return ([],chart)
peekCCats get_range chart len ptr = do
(root, chart) <- deRef (peekCCat get_range chart) ptr
(roots,chart) <- peekCCats get_range chart (len-1) (ptr `plusPtr` (#size PgfCCat*))
return (root:roots,chart)
peekCCat get_range chart c_ccat = do
fid <- peekFId c_ccat
c_total_cats <- (#peek PgfConcr, total_cats) (concr lang)
if Map.member fid chart || fid < c_total_cats
then return (fid,chart)
else do c_cnccat <- (#peek PgfCCat, cnccat) c_ccat
c_abscat <- (#peek PgfCCat, cnccat) c_cnccat
c_name <- (#peek PgfCCat, cnccat) c_abscat
cat <- peekUtf8CString c_name
range <- get_range c_ccat >>= peekSequence peekRange (#size PgfParseRange)
c_prods <- (#peek PgfCCat, prods) c_ccat
if c_prods == nullPtr
then do return (fid,Map.insert fid (range,[],cat) chart)
else do c_len <- (#peek PgfCCat, n_synprods) c_ccat
(prods,chart) <- fixIO (\res -> peekProductions (Map.insert fid (range,fst res,cat) chart)
(fromIntegral (c_len :: CSizeT))
(c_prods `plusPtr` (#offset GuSeq, data)))
return (fid,chart)
where
peekProductions chart 0 ptr = return ([],chart)
peekProductions chart len ptr = do
(ps1,chart) <- deRef (peekProduction chart) ptr
(ps2,chart) <- peekProductions chart (len-1) (ptr `plusPtr` (#size GuVariant))
return (ps1++ps2,chart)
peekProduction chart p = do
tag <- gu_variant_tag p
dt <- gu_variant_data p
case tag of
(#const PGF_PRODUCTION_APPLY) -> do { c_cncfun <- (#peek PgfProductionApply, fun) dt ;
c_absfun <- (#peek PgfCncFun, absfun) c_cncfun ;
expr <- (#peek PgfAbsFun, ep.expr) c_absfun ;
p <- (#peek PgfAbsFun, ep.prob) c_absfun ;
c_args <- (#peek PgfProductionApply, args) dt ;
c_len <- (#peek GuSeq, len) c_args ;
(pargs,chart) <- peekPArgs chart (c_len :: CSizeT) (c_args `plusPtr` (#offset GuSeq, data)) ;
return ([(Expr expr (touchConcr lang), pargs, p)],chart) }
(#const PGF_PRODUCTION_COERCE) -> do { c_coerce <- (#peek PgfProductionCoerce, coerce) dt ;
(fid,chart) <- peekCCat get_range chart c_coerce ;
return (maybe [] snd3 (Map.lookup fid chart),chart) }
(#const PGF_PRODUCTION_EXTERN) -> do { c_ep <- (#peek PgfProductionExtern, ep) dt ;
expr <- (#peek PgfExprProb, expr) c_ep ;
p <- (#peek PgfExprProb, prob) c_ep ;
return ([(Expr expr (touchConcr lang), [], p)],chart) }
_ -> error ("Unknown production type "++show tag++" in the grammar")
snd3 (_,x,_) = x
peekPArgs chart 0 ptr = return ([],chart)
peekPArgs chart len ptr = do
(a, chart) <- peekPArg chart ptr
(as,chart) <- peekPArgs chart (len-1) (ptr `plusPtr` (#size PgfPArg))
return (a:as,chart)
peekPArg chart ptr = do
c_hypos <- (#peek PgfPArg, hypos) ptr
hypos <- if c_hypos /= nullPtr
then do res <- peekSequence (deRef peekFId) (#size int) c_hypos
return [(fid,fid) | fid <- res]
else return []
c_ccat <- (#peek PgfPArg, ccat) ptr
(fid,chart) <- peekCCat get_range chart c_ccat
return (PArg hypos fid,chart)
peekRange ptr = do
s <- (#peek PgfParseRange, start) ptr
e <- (#peek PgfParseRange, end) ptr
f <- (#peek PgfParseRange, field) ptr >>= peekCString
return ((fromIntegral :: CSizeT -> Int) s, (fromIntegral :: CSizeT -> Int) e, f)
mkCallbacksMap :: Ptr PgfConcr -> [(String, String -> Int -> Maybe (Expr,Float,Int))] -> Ptr GuPool -> IO (Ptr PgfCallbacksMap)
mkCallbacksMap concr callbacks pool = do
callbacks_map <- pgf_new_callbacks_map concr pool
forM_ callbacks $ \(cat,match) -> do
@@ -1095,23 +1299,15 @@ mkCallbacksMap concr callbacks pool = do
hspgf_callbacks_map_add_literal concr callbacks_map ccat match predict pool
return callbacks_map
where
match_callback match clin_idx poffset out_pool = do
match_callback match c_ann poffset out_pool = do
coffset <- peek poffset
case match (fromIntegral clin_idx) (fromIntegral coffset) of
ann <- peekUtf8CString c_ann
case match ann (fromIntegral coffset) of
Nothing -> return nullPtr
Just (e,prob,offset') -> do poke poffset (fromIntegral offset')
-- here we copy the expression to out_pool
c_e <- withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
(sb,out) <- newOut tmpPl
let printCtxt = nullPtr
pgf_print_expr (expr e) printCtxt 1 out exn
c_str <- gu_string_buf_freeze sb tmpPl
guin <- gu_string_in c_str tmpPl
pgf_read_expr guin out_pool tmpPl exn
c_e <- pgf_clone_expr (expr e) out_pool
ep <- gu_malloc out_pool (#size PgfExprProb)
(#poke PgfExprProb, expr) ep c_e
@@ -1120,26 +1316,6 @@ mkCallbacksMap concr callbacks pool = do
predict_callback _ _ _ = return nullPtr
complete :: Concr -- ^ the language with which we do word completion
-> Type -- ^ the start category
-> String -- ^ the input sentence
-> String -- ^ prefix for the word to be completed
-> [(String, Cat, Fun, Float)]
complete lang (Type ctype _) sent prefix =
unsafePerformIO $
do pl <- gu_new_pool
exn <- gu_new_exn pl
sent <- newUtf8CString sent pl
prefix <- newUtf8CString prefix pl
enum <- pgf_complete (concr lang) ctype sent prefix exn pl
failed <- gu_exn_is_raised exn
if failed
then do gu_pool_free pl
return []
else do fpl <- newForeignPtr gu_pool_finalizer pl
tokens <- fromPgfTokenEnum enum fpl
return tokens
lookupSentence :: Concr -- ^ the language with which we parse
-> Type -- ^ the start category
-> String -- ^ the input sentence
@@ -1158,7 +1334,7 @@ lookupSentence lang (Type ctype _) sent =
-- | The oracle is a triple of functions.
-- The first two take a category name and a linearization field name
-- and they should return True/False when the corresponding
-- and they should return True/False when the corresponding
-- prediction or completion is appropriate. The third function
-- is the oracle for literals.
type Oracle = (Maybe (Cat -> String -> Int -> Bool)
@@ -1170,7 +1346,7 @@ parseWithOracle :: Concr -- ^ the language with which we parse
-> Cat -- ^ the start category
-> String -- ^ the input sentence
-> Oracle
-> ParseOutput
-> ParseOutput [(Expr,Float)]
parseWithOracle lang cat sent (predict,complete,literal) =
unsafePerformIO $
do parsePl <- gu_new_pool
@@ -1246,6 +1422,67 @@ parseWithOracle lang cat sent (predict,complete,literal) =
return ep
Nothing -> do return nullPtr
-- | Returns possible completions of the current partial input.
complete :: Concr -- ^ the language with which we parse
-> Type -- ^ the start category
-> String -- ^ the input sentence (excluding token being completed)
-> String -- ^ prefix (partial token being completed)
-> ParseOutput [(String, Fun, Cat, Float)] -- ^ (token, category, function, probability)
complete lang (Type ctype _) sent pfx =
unsafePerformIO $ do
parsePl <- gu_new_pool
exn <- gu_new_exn parsePl
sent <- newUtf8CString sent parsePl
pfx <- newUtf8CString pfx parsePl
enum <- pgf_complete (concr lang) ctype sent pfx exn parsePl
failed <- gu_exn_is_raised exn
if failed
then do
is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError
if is_parse_error
then do
c_err <- (#peek GuExn, data.data) exn
c_offset <- (#peek PgfParseError, offset) c_err
token_ptr <- (#peek PgfParseError, token_ptr) c_err
token_len <- (#peek PgfParseError, token_len) c_err
tok <- peekUtf8CStringLen token_ptr token_len
gu_pool_free parsePl
return (ParseFailed (fromIntegral (c_offset :: CInt)) tok)
else do
is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
if is_exn
then do
c_msg <- (#peek GuExn, data.data) exn
msg <- peekUtf8CString c_msg
gu_pool_free parsePl
throwIO (PGFError msg)
else do
gu_pool_free parsePl
throwIO (PGFError "Parsing failed")
else do
fpl <- newForeignPtr gu_pool_finalizer parsePl
ParseOk <$> fromCompletions enum fpl
where
fromCompletions :: Ptr GuEnum -> ForeignPtr GuPool -> IO [(String, Cat, Fun, Float)]
fromCompletions enum fpl =
withGuPool $ \tmpPl -> do
cmpEntry <- alloca $ \ptr ->
withForeignPtr fpl $ \pl ->
do gu_enum_next enum ptr pl
peek ptr
if cmpEntry == nullPtr
then do
finalizeForeignPtr fpl
touchConcr lang
return []
else do
tok <- peekUtf8CString =<< (#peek PgfTokenProb, tok) cmpEntry
cat <- peekUtf8CString =<< (#peek PgfTokenProb, cat) cmpEntry
fun <- peekUtf8CString =<< (#peek PgfTokenProb, fun) cmpEntry
prob <- (#peek PgfTokenProb, prob) cmpEntry
toks <- unsafeInterleaveIO (fromCompletions enum fpl)
return ((tok, cat, fun, prob) : toks)
-- | Returns True if there is a linearization defined for that function in that language
hasLinearization :: Concr -> Fun -> Bool
hasLinearization lang id = unsafePerformIO $
@@ -1319,7 +1556,7 @@ linearizeAll lang e = unsafePerformIO $
-- | Generates a table of linearizations for an expression
tabularLinearize :: Concr -> Expr -> [(String, String)]
tabularLinearize lang e =
tabularLinearize lang e =
case tabularLinearizeAll lang e of
(lins:_) -> lins
_ -> []
@@ -1331,6 +1568,7 @@ tabularLinearizeAll lang e = unsafePerformIO $
exn <- gu_new_exn tmpPl
cts <- pgf_lzr_concretize (concr lang) (expr e) exn tmpPl
failed <- gu_exn_is_raised exn
touchConcr lang
if failed
then throwExn exn
else collect cts exn tmpPl
@@ -1368,45 +1606,58 @@ tabularLinearizeAll lang e = unsafePerformIO $
ss <- collectTable lang ctree (lin_idx+1) labels exn tmpPl
return ((label,s):ss)
throwExn exn = do
is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
if is_exn
then do c_msg <- (#peek GuExn, data.data) exn
msg <- peekUtf8CString c_msg
throwIO (PGFError msg)
else do throwIO (PGFError "The abstract tree cannot be linearized")
categoryFields :: Concr -> Cat -> Maybe [String]
categoryFields lang cat =
unsafePerformIO $ do
withGuPool $ \tmpPl -> do
p_n_lins <- gu_malloc tmpPl (#size size_t)
c_cat <- newUtf8CString cat tmpPl
c_fields <- pgf_category_fields (concr lang) c_cat p_n_lins
if c_fields == nullPtr
then do touchConcr lang
return Nothing
else do len <- peek p_n_lins
fs <- peekFields len c_fields
touchConcr lang
return (Just fs)
where
peekFields 0 ptr = return []
peekFields len ptr = do
f <- peek ptr >>= peekUtf8CString
fs <- peekFields (len-1) (ptr `plusPtr` (#size GuString))
return (f:fs)
type FId = Int
type LIndex = Int
-- | BracketedString represents a sentence that is linearized
-- as usual but we also want to retain the ''brackets'' that
-- mark the beginning and the end of each constituent.
data BracketedString
= Leaf String -- ^ this is the leaf i.e. a single token
| Bracket Cat {-# UNPACK #-} !FId {-# UNPACK #-} !LIndex Fun [BracketedString]
| BIND -- ^ the surrounding tokens must be bound together
| Bracket Cat {-# UNPACK #-} !FId String Fun [BracketedString]
-- ^ this is a bracket. The 'Cat' is the category of
-- the phrase. The 'FId' is an unique identifier for
-- every phrase in the sentence. For context-free grammars
-- i.e. without discontinuous constituents this identifier
-- is also unique for every bracket. When there are discontinuous
-- is also unique for every bracket. When there are discontinuous
-- phrases then the identifiers are unique for every phrase but
-- not for every bracket since the bracket represents a constituent.
-- The different constituents could still be distinguished by using
-- the constituent index i.e. 'LIndex'. If the grammar is reduplicating
-- the analysis string. If the grammar is reduplicating
-- then the constituent indices will be the same for all brackets
-- that represents the same constituent.
-- The 'Fun' is the name of the abstract function that generated
-- this phrase.
-- | Renders the bracketed string as a string where
-- | Renders the bracketed string as a string where
-- the brackets are shown as @(S ...)@ where
-- @S@ is the category.
showBracketedString :: BracketedString -> String
showBracketedString = render . ppBracketedString
ppBracketedString (Leaf t) = text t
ppBracketedString (Bracket cat fid index _ bss) = parens (text cat <> colon <> int fid <+> hsep (map ppBracketedString bss))
ppBracketedString BIND = text "&+"
ppBracketedString (Bracket cat fid _ _ bss) = parens (text cat <> colon <> int fid <+> hsep (map ppBracketedString bss))
-- | Extracts the sequence of tokens from the bracketed string
flattenBracketedString :: BracketedString -> [String]
@@ -1415,7 +1666,7 @@ flattenBracketedString (Bracket _ _ _ _ bss) = concatMap flattenBracketedString
bracketedLinearize :: Concr -> Expr -> [BracketedString]
bracketedLinearize lang e = unsafePerformIO $
withGuPool $ \pl ->
withGuPool $ \pl ->
do exn <- gu_new_exn pl
cts <- pgf_lzr_concretize (concr lang) (expr e) exn pl
failed <- gu_exn_is_raised exn
@@ -1428,27 +1679,8 @@ bracketedLinearize lang e = unsafePerformIO $
return []
else do ctree <- pgf_lzr_wrap_linref ctree pl
ref <- newIORef ([],[])
allocaBytes (#size PgfLinFuncs) $ \pLinFuncs ->
alloca $ \ppLinFuncs -> do
fptr_symbol_token <- wrapSymbolTokenCallback (symbol_token ref)
fptr_begin_phrase <- wrapPhraseCallback (begin_phrase ref)
fptr_end_phrase <- wrapPhraseCallback (end_phrase ref)
fptr_symbol_ne <- wrapSymbolNonExistCallback (symbol_ne exn)
fptr_symbol_meta <- wrapSymbolMetaCallback (symbol_meta ref)
(#poke PgfLinFuncs, symbol_token) pLinFuncs fptr_symbol_token
(#poke PgfLinFuncs, begin_phrase) pLinFuncs fptr_begin_phrase
(#poke PgfLinFuncs, end_phrase) pLinFuncs fptr_end_phrase
(#poke PgfLinFuncs, symbol_ne) pLinFuncs fptr_symbol_ne
(#poke PgfLinFuncs, symbol_bind) pLinFuncs nullPtr
(#poke PgfLinFuncs, symbol_capit) pLinFuncs nullPtr
(#poke PgfLinFuncs, symbol_meta) pLinFuncs fptr_symbol_meta
poke ppLinFuncs pLinFuncs
pgf_lzr_linearize (concr lang) ctree 0 ppLinFuncs pl
freeHaskellFunPtr fptr_symbol_token
freeHaskellFunPtr fptr_begin_phrase
freeHaskellFunPtr fptr_end_phrase
freeHaskellFunPtr fptr_symbol_ne
freeHaskellFunPtr fptr_symbol_meta
withBracketLinFuncs ref exn $ \ppLinFuncs ->
pgf_lzr_linearize (concr lang) ctree 0 ppLinFuncs pl
failed <- gu_exn_is_raised exn
if failed
then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist
@@ -1457,41 +1689,105 @@ bracketedLinearize lang e = unsafePerformIO $
else throwExn exn
else do (_,bs) <- readIORef ref
return (reverse bs)
bracketedLinearizeAll :: Concr -> Expr -> [[BracketedString]]
bracketedLinearizeAll lang e = unsafePerformIO $
withGuPool $ \pl ->
do exn <- gu_new_exn pl
cts <- pgf_lzr_concretize (concr lang) (expr e) exn pl
failed <- gu_exn_is_raised exn
if failed
then do touchExpr e
throwExn exn
else do ref <- newIORef ([],[])
bss <- withBracketLinFuncs ref exn $ \ppLinFuncs ->
collect ref cts ppLinFuncs exn pl
touchExpr e
return bss
where
collect ref cts ppLinFuncs exn pl = withGuPool $ \tmpPl -> do
ctree <- alloca $ \ptr -> do gu_enum_next cts ptr tmpPl
peek ptr
if ctree == nullPtr
then return []
else do ctree <- pgf_lzr_wrap_linref ctree pl
pgf_lzr_linearize (concr lang) ctree 0 ppLinFuncs pl
failed <- gu_exn_is_raised exn
if failed
then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist
if is_nonexist
then collect ref cts ppLinFuncs exn pl
else throwExn exn
else do (_,bs) <- readIORef ref
writeIORef ref ([],[])
bss <- collect ref cts ppLinFuncs exn pl
return (reverse bs : bss)
withBracketLinFuncs ref exn f =
allocaBytes (#size PgfLinFuncs) $ \pLinFuncs ->
alloca $ \ppLinFuncs -> do
fptr_symbol_token <- wrapSymbolTokenCallback (symbol_token ref)
fptr_begin_phrase <- wrapPhraseCallback (begin_phrase ref)
fptr_end_phrase <- wrapPhraseCallback (end_phrase ref)
fptr_symbol_ne <- wrapSymbolNonExistCallback (symbol_ne exn)
fptr_symbol_bind <- wrapSymbolBindCallback (symbol_bind ref)
fptr_symbol_meta <- wrapSymbolMetaCallback (symbol_meta ref)
(#poke PgfLinFuncs, symbol_token) pLinFuncs fptr_symbol_token
(#poke PgfLinFuncs, begin_phrase) pLinFuncs fptr_begin_phrase
(#poke PgfLinFuncs, end_phrase) pLinFuncs fptr_end_phrase
(#poke PgfLinFuncs, symbol_ne) pLinFuncs fptr_symbol_ne
(#poke PgfLinFuncs, symbol_bind) pLinFuncs fptr_symbol_bind
(#poke PgfLinFuncs, symbol_capit) pLinFuncs nullPtr
(#poke PgfLinFuncs, symbol_meta) pLinFuncs fptr_symbol_meta
poke ppLinFuncs pLinFuncs
res <- f ppLinFuncs
freeHaskellFunPtr fptr_symbol_token
freeHaskellFunPtr fptr_begin_phrase
freeHaskellFunPtr fptr_end_phrase
freeHaskellFunPtr fptr_symbol_ne
freeHaskellFunPtr fptr_symbol_bind
freeHaskellFunPtr fptr_symbol_meta
return res
where
symbol_token ref _ c_token = do
(stack,bs) <- readIORef ref
token <- peekUtf8CString c_token
writeIORef ref (stack,Leaf token : bs)
begin_phrase ref _ c_cat c_fid c_lindex c_fun = do
begin_phrase ref _ c_cat c_fid c_ann c_fun = do
(stack,bs) <- readIORef ref
writeIORef ref (bs:stack,[])
end_phrase ref _ c_cat c_fid c_lindex c_fun = do
end_phrase ref _ c_cat c_fid c_ann c_fun = do
(bs':stack,bs) <- readIORef ref
if null bs
then writeIORef ref (stack, bs')
else do cat <- peekUtf8CString c_cat
let fid = fromIntegral c_fid
let lindex = fromIntegral c_lindex
ann <- peekUtf8CString c_ann
fun <- peekUtf8CString c_fun
writeIORef ref (stack, Bracket cat fid lindex fun (reverse bs) : bs')
writeIORef ref (stack, Bracket cat fid ann fun (reverse bs) : bs')
symbol_ne exn _ = do
gu_exn_raise exn gu_exn_type_PgfLinNonExist
return ()
symbol_bind ref _ = do
(stack,bs) <- readIORef ref
writeIORef ref (stack,BIND : bs)
return ()
symbol_meta ref _ meta_id = do
(stack,bs) <- readIORef ref
writeIORef ref (stack,Leaf "?" : bs)
throwExn exn = do
is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
if is_exn
then do c_msg <- (#peek GuExn, data.data) exn
msg <- peekUtf8CString c_msg
throwIO (PGFError msg)
else do throwIO (PGFError "The abstract tree cannot be linearized")
throwExn exn = do
is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
if is_exn
then do c_msg <- (#peek GuExn, data.data) exn
msg <- peekUtf8CString c_msg
throwIO (PGFError msg)
else do throwIO (PGFError "The abstract tree cannot be linearized")
alignWords :: Concr -> Expr -> [(String, [Int])]
alignWords lang e = unsafePerformIO $
@@ -1684,13 +1980,13 @@ instance Exception PGFError
-----------------------------------------------------------------------
type LiteralCallback =
PGF -> (ConcName,Concr) -> String -> Int -> Int -> Maybe (Expr,Float,Int)
PGF -> (ConcName,Concr) -> String -> String -> Int -> Maybe (Expr,Float,Int)
-- | Callbacks for the App grammar
literalCallbacks :: [(AbsName,[(Cat,LiteralCallback)])]
literalCallbacks = [("App",[("PN",nerc),("Symb",chunk)])]
-- | Named entity recognition for the App grammar
-- | Named entity recognition for the App grammar
-- (based on ../java/org/grammaticalframework/pgf/NercLiteralCallback.java)
nerc :: LiteralCallback
nerc pgf (lang,concr) sentence lin_idx offset =

12
src/runtime/haskell/PGF2/Expr.hsc
View File

@@ -13,7 +13,7 @@ import Data.Maybe(fromJust)
type Cat = String -- ^ Name of syntactic category
type Fun = String -- ^ Name of function
data BindType =
data BindType =
Explicit
| Implicit
deriving (Show, Eq, Ord)
@@ -32,7 +32,7 @@ instance Show Expr where
show = showExpr []
instance Eq Expr where
(Expr e1 e1_touch) == (Expr e2 e2_touch) =
(Expr e1 e1_touch) == (Expr e2 e2_touch) =
unsafePerformIO $ do
res <- pgf_expr_eq e1 e2
e1_touch >> e2_touch
@@ -107,9 +107,9 @@ unApp (Expr expr touch) =
appl <- pgf_expr_unapply expr pl
if appl == nullPtr
then return Nothing
else do
else do
fun <- peekCString =<< (#peek PgfApplication, fun) appl
arity <- (#peek PgfApplication, n_args) appl :: IO CInt
arity <- (#peek PgfApplication, n_args) appl :: IO CInt
c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args))
return $ Just (fun, [Expr c_arg touch | c_arg <- c_args])
@@ -145,7 +145,9 @@ unStr (Expr expr touch) =
touch
return (Just s)
-- | Constructs an expression from an integer literal
-- | Constructs an expression from an integer literal.
-- Note that the C runtime does not support long integers, and you may run into overflow issues with large values.
-- See [here](https://github.com/GrammaticalFramework/gf-core/issues/109) for more details.
mkInt :: Int -> Expr
mkInt val =
unsafePerformIO $ do

55
src/runtime/haskell/PGF2/FFI.hsc
View File

@@ -6,6 +6,7 @@ module PGF2.FFI where
#include <gu/hash.h>
#include <gu/utf8.h>
#include <pgf/pgf.h>
#include <pgf/data.h>
import Foreign ( alloca, peek, poke, peekByteOff )
import Foreign.C
@@ -102,7 +103,7 @@ foreign import ccall unsafe "gu/file.h gu_file_in"
foreign import ccall safe "gu/enum.h gu_enum_next"
gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO ()
foreign import ccall unsafe "gu/string.h gu_string_buf_freeze"
gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString
@@ -237,6 +238,16 @@ newSequence elem_size pokeElem values pool = do
pokeElem ptr x
pokeElems (ptr `plusPtr` (fromIntegral elem_size)) xs
type FId = Int
data PArg = PArg [(FId,FId)] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
peekFId :: Ptr a -> IO FId
peekFId c_ccat = do
c_fid <- (#peek PgfCCat, fid) c_ccat
return (fromIntegral (c_fid :: CInt))
deRef peekValue ptr = peek ptr >>= peekValue
------------------------------------------------------------------
-- libpgf API
@@ -245,6 +256,7 @@ data PgfApplication
data PgfConcr
type PgfExpr = Ptr ()
data PgfExprProb
data PgfTokenProb
data PgfExprParser
data PgfFullFormEntry
data PgfMorphoCallback
@@ -261,6 +273,7 @@ data PgfAbsCat
data PgfCCat
data PgfCncFun
data PgfProductionApply
data PgfParsing
foreign import ccall "pgf/pgf.h pgf_read"
pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF)
@@ -310,6 +323,9 @@ foreign import ccall "pgf/pgf.h pgf_category_context"
foreign import ccall "pgf/pgf.h pgf_category_prob"
pgf_category_prob :: Ptr PgfPGF -> CString -> IO (#type prob_t)
foreign import ccall "pgf/pgf.h pgf_category_fields"
pgf_category_fields :: Ptr PgfConcr -> CString -> Ptr CSize -> IO (Ptr CString)
foreign import ccall "pgf/pgf.h pgf_iter_functions"
pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
@@ -347,8 +363,9 @@ foreign import ccall "pgf/pgf.h pgf_lzr_get_table"
pgf_lzr_get_table :: Ptr PgfConcr -> Ptr PgfCncTree -> Ptr CSizeT -> Ptr (Ptr CString) -> IO ()
type SymbolTokenCallback = Ptr (Ptr PgfLinFuncs) -> CString -> IO ()
type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CSizeT -> CString -> IO ()
type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CString -> CString -> IO ()
type NonExistCallback = Ptr (Ptr PgfLinFuncs) -> IO ()
type BindCallback = Ptr (Ptr PgfLinFuncs) -> IO ()
type MetaCallback = Ptr (Ptr PgfLinFuncs) -> CInt -> IO ()
foreign import ccall "wrapper"
@@ -360,27 +377,36 @@ foreign import ccall "wrapper"
foreign import ccall "wrapper"
wrapSymbolNonExistCallback :: NonExistCallback -> IO (FunPtr NonExistCallback)
foreign import ccall "wrapper"
wrapSymbolBindCallback :: BindCallback -> IO (FunPtr BindCallback)
foreign import ccall "wrapper"
wrapSymbolMetaCallback :: MetaCallback -> IO (FunPtr MetaCallback)
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_to_chart"
pgf_parse_to_chart :: Ptr PgfConcr -> PgfType -> CString -> Double -> Ptr PgfCallbacksMap -> CSizeT -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr PgfParsing)
foreign import ccall "pgf/pgf.h pgf_get_parse_roots"
pgf_get_parse_roots :: Ptr PgfParsing -> Ptr GuPool -> IO (Ptr GuSeq)
foreign import ccall "pgf/pgf.h pgf_ccat_to_range"
pgf_ccat_to_range :: Ptr PgfParsing -> Ptr PgfCCat -> Ptr GuPool -> IO (Ptr GuSeq)
foreign import ccall "pgf/pgf.h pgf_parse_with_heuristics"
pgf_parse_with_heuristics :: Ptr PgfConcr -> PgfType -> CString -> Double -> Ptr PgfCallbacksMap -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
foreign import ccall "pgf/pgf.h pgf_complete"
pgf_complete :: Ptr PgfConcr -> PgfType -> CString -> CString -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuEnum)
foreign import ccall "pgf/pgf.h pgf_lookup_sentence"
pgf_lookup_sentence :: Ptr PgfConcr -> PgfType -> CString -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
type LiteralMatchCallback = CSizeT -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb)
type LiteralMatchCallback = CString -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb)
foreign import ccall "wrapper"
wrapLiteralMatchCallback :: LiteralMatchCallback -> IO (FunPtr LiteralMatchCallback)
type LiteralPredictCallback = CSizeT -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb)
type LiteralPredictCallback = CString -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb)
foreign import ccall "wrapper"
wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback)
@@ -406,6 +432,9 @@ foreign import ccall
foreign import ccall "pgf/pgf.h pgf_parse_with_oracle"
pgf_parse_with_oracle :: Ptr PgfConcr -> CString -> CString -> Ptr PgfOracleCallback -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
foreign import ccall "pgf/pgf.h pgf_complete"
pgf_complete :: Ptr PgfConcr -> PgfType -> CString -> CString -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuEnum)
foreign import ccall "pgf/pgf.h pgf_lookup_morpho"
pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
@@ -500,9 +529,6 @@ foreign import ccall "pgf/expr.h pgf_compute"
foreign import ccall "pgf/expr.h pgf_print_expr"
pgf_print_expr :: PgfExpr -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/expr.h pgf_print_expr_tuple"
pgf_print_expr_tuple :: CSizeT -> 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 ()
@@ -518,12 +544,6 @@ foreign import ccall "pgf/pgf.h pgf_print"
foreign import ccall "pgf/expr.h pgf_read_expr"
pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr
foreign import ccall "pgf/expr.h pgf_read_expr_tuple"
pgf_read_expr_tuple :: Ptr GuIn -> CSizeT -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt
foreign import ccall "pgf/expr.h pgf_read_expr_matrix"
pgf_read_expr_matrix :: Ptr GuIn -> CSizeT -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq)
foreign import ccall "pgf/expr.h pgf_read_type"
pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfType
@@ -544,3 +564,6 @@ foreign import ccall "pgf/data.h pgf_lzr_index"
foreign import ccall "pgf/data.h pgf_production_is_lexical"
pgf_production_is_lexical :: Ptr PgfProductionApply -> Ptr GuBuf -> Ptr GuPool -> IO (#type bool)
foreign import ccall "pgf/expr.h pgf_clone_expr"
pgf_clone_expr :: PgfExpr -> Ptr GuPool -> IO PgfExpr

13
src/runtime/haskell/PGF2/Internal.hsc
View File

@@ -2,7 +2,7 @@
module PGF2.Internal(-- * Access the internal structures
FId,isPredefFId,
FunId,SeqId,Token,Production(..),PArg(..),Symbol(..),Literal(..),
FunId,SeqId,LIndex,Token,Production(..),PArg(..),Symbol(..),Literal(..),
globalFlags, abstrFlags, concrFlags,
concrTotalCats, concrCategories, concrProductions,
concrTotalFuns, concrFunction,
@@ -42,7 +42,8 @@ import Control.Exception(Exception,throwIO)
import Control.Monad(foldM,when)
import qualified Data.Map as Map
type Token = String
type Token = String
type LIndex = Int
data Symbol
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
@@ -60,7 +61,7 @@ data Production
= PApply {-# UNPACK #-} !FunId [PArg]
| PCoerce {-# UNPACK #-} !FId
deriving (Eq,Ord,Show)
data PArg = PArg [(FId,FId)] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
type FunId = Int
type SeqId = Int
data Literal =
@@ -229,10 +230,6 @@ concrProductions c fid = unsafePerformIO $ do
fid <- peekFId c_ccat
return (PArg [(fid,fid) | fid <- hypos] fid)
peekFId c_ccat = do
c_fid <- (#peek PgfCCat, fid) c_ccat
return (fromIntegral (c_fid :: CInt))
concrTotalFuns :: Concr -> FunId
concrTotalFuns c = unsafePerformIO $ do
c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c)
@@ -320,8 +317,6 @@ concrSequence c seqid = unsafePerformIO $ do
forms <- peekForms (len-1) (ptr `plusPtr` (#size PgfAlternative))
return ((form,prefixes):forms)
deRef peekValue ptr = peek ptr >>= peekValue
fidString, fidInt, fidFloat, fidVar, fidStart :: FId
fidString = (-1)
fidInt = (-2)

26
src/runtime/haskell/README
View File

@@ -1,26 +0,0 @@
This is a binding to the new GF runtime in C.
The files are:
PGF2.hsc -- a user API similar to Python and Java APIs
PGF2/FFI.hs -- an internal module with FFI definitions for
-- the relevant C functions
HOW TO COMPILE:
cabal install
HOW TO USE:
- Import PGF to the Haskell program that you're writing.
The Cabal infrastructure will make sure to tell the compiler
where to find the relevant modules. Example:
module Main where
import PGF2
import qualified Data.Map as Map
main = do
pgf <- readPGF "Foo.pgf"
let Just english = Map.lookup "FooEng" (languages pgf)

56
src/runtime/haskell/README.md Normal file
View File

@@ -0,0 +1,56 @@
# PGF2
This is a Haskell binding to the PGF runtime written in C.
The exposed modules are:
- `PGF2`: a user API similar to Python and Java APIs
- `PGF2.Internal`: an internal module with FFI definitions for the relevant C functions
## How to compile
**Important:** You must have the C runtime already installed and available on your system.
See <https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL>
Once the runtine is installed, you can install the library to your global Cabal installation:
```
cabal install pgf2 --extra-lib-dirs=/usr/local/lib
```
or add it to your `stack.yaml` file:
```yaml
extra-deps:
- pgf2
extra-lib-dirs:
- /usr/local/lib
```
## How to use
Simply import `PGF2` in your Haskell program.
The Cabal infrastructure will make sure to tell the compiler where to find the relevant modules.
## Example
```haskell
module Main where
import PGF2
import qualified Data.Map as Map
main = do
pgf <- readPGF "App12.pgf"
let Just eng = Map.lookup "AppEng" (languages pgf)
-- Parsing
let res = parse eng (startCat pgf) "this is a small theatre"
let ParseOk ((tree,prob):rest) = res
print tree
-- Linearisation
let Just expr = readExpr "AdjCN (PositA red_A) (UseN theatre_N)"
let s = linearize eng expr
print s
```

349
src/runtime/haskell/SG.hsc
View File

@@ -1,349 +0,0 @@
{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification #-}
#include <pgf/pgf.h>
#include <gu/exn.h>
#include <sg/sg.h>
module SG( SG, openSG, closeSG
, beginTrans, commit, rollback, inTransaction
, SgId
, insertExpr, getExpr, queryExpr
, updateFtsIndex
, queryLinearization
, readTriple, showTriple
, insertTriple, getTriple
, queryTriple
, query
) where
import Foreign hiding (unsafePerformIO)
import Foreign.C
import SG.FFI
import PGF2.FFI
import PGF2.Expr
import Data.Typeable
import Control.Exception(Exception,SomeException,catch,throwIO)
import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO)
-----------------------------------------------------------------------
-- Global database operations and types
newtype SG = SG {sg :: Ptr SgSG}
openSG :: FilePath -> IO SG
openSG fpath =
withCString fpath $ \c_fpath ->
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
sg <- sg_open c_fpath exn
failed <- gu_exn_is_raised exn
if failed
then do is_errno <- gu_exn_caught exn gu_exn_type_GuErrno
if is_errno
then do perrno <- (#peek GuExn, data.data) exn
errno <- peek perrno
ioError (errnoToIOError "openSG" (Errno errno) Nothing (Just fpath))
else do is_sgerr <- gu_exn_caught exn gu_exn_type_SgError
if is_sgerr
then do c_msg <- (#peek GuExn, data.data) exn
msg <- peekUtf8CString c_msg
throwIO (SGError msg)
else throwIO (SGError "The database cannot be opened")
else return (SG sg)
closeSG :: SG -> IO ()
closeSG (SG sg) =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
sg <- sg_close sg exn
handle_sg_exn exn
beginTrans :: SG -> IO ()
beginTrans (SG sg) =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
sg <- sg_begin_trans sg exn
handle_sg_exn exn
commit :: SG -> IO ()
commit (SG sg) =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
sg <- sg_commit sg exn
handle_sg_exn exn
rollback :: SG -> IO ()
rollback (SG sg) =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
sg <- sg_rollback sg exn
handle_sg_exn exn
inTransaction :: SG -> IO a -> IO a
inTransaction sg f =
catch (beginTrans sg >> f >>= \x -> commit sg >> return x)
(\e -> rollback sg >> throwIO (e :: SomeException))
-----------------------------------------------------------------------
-- Expressions
insertExpr :: SG -> Expr -> IO SgId
insertExpr (SG sg) (Expr expr touch) =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
id <- sg_insert_expr sg expr 1 exn
touch
handle_sg_exn exn
return id
getExpr :: SG -> SgId -> IO (Maybe Expr)
getExpr (SG sg) id = do
exprPl <- gu_new_pool
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
c_expr <- sg_get_expr sg id exprPl exn
handle_sg_exn exn
if c_expr == nullPtr
then do touchForeignPtr exprFPl
return Nothing
else do return $ Just (Expr c_expr (touchForeignPtr exprFPl))
queryExpr :: SG -> Expr -> IO [(SgId,Expr)]
queryExpr (SG sg) (Expr query touch) =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
res <- sg_query_expr sg query tmpPl exn
touch
handle_sg_exn exn
fetchResults res exn
where
fetchResults res exn = do
exprPl <- gu_new_pool
(key,c_expr) <- alloca $ \pKey -> do
c_expr <- sg_query_next sg res pKey exprPl exn
key <- peek pKey
return (key,c_expr)
failed <- gu_exn_is_raised exn
if failed
then do gu_pool_free exprPl
sg_query_close sg res exn
handle_sg_exn exn
return []
else if c_expr == nullPtr
then do gu_pool_free exprPl
sg_query_close sg res exn
return []
else do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
rest <- fetchResults res exn
return ((key,Expr c_expr (touchForeignPtr exprFPl)) : rest)
updateFtsIndex :: SG -> PGF -> IO ()
updateFtsIndex (SG sg) p = do
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
sg_update_fts_index sg (pgf p) exn
handle_sg_exn exn
queryLinearization :: SG -> String -> IO [Expr]
queryLinearization (SG sg) query = do
exprPl <- gu_new_pool
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
(withGuPool $ \tmpPl -> do
c_query <- newUtf8CString query tmpPl
exn <- gu_new_exn tmpPl
seq <- sg_query_linearization sg c_query tmpPl exn
handle_sg_exn exn
len <- (#peek GuSeq, len) seq
ids <- peekArray (fromIntegral (len :: CInt)) (seq `plusPtr` (#offset GuSeq, data))
getExprs exprFPl exprPl exn ids)
where
getExprs exprFPl exprPl exn [] = return []
getExprs exprFPl exprPl exn (id:ids) = do
c_expr <- sg_get_expr sg id exprPl exn
handle_sg_exn exn
if c_expr == nullPtr
then getExprs exprFPl exprPl exn ids
else do let e = Expr c_expr (touchForeignPtr exprFPl)
es <- getExprs exprFPl exprPl exn ids
return (e:es)
-----------------------------------------------------------------------
-- Triples
readTriple :: String -> Maybe (Expr,Expr,Expr)
readTriple str =
unsafePerformIO $
do exprPl <- gu_new_pool
withGuPool $ \tmpPl ->
withTriple $ \triple ->
do c_str <- newUtf8CString str tmpPl
guin <- gu_string_in c_str tmpPl
exn <- gu_new_exn tmpPl
ok <- pgf_read_expr_tuple guin 3 triple exprPl exn
status <- gu_exn_is_raised exn
if (ok == 1 && not status)
then do c_expr1 <- peekElemOff triple 0
c_expr2 <- peekElemOff triple 1
c_expr3 <- peekElemOff triple 2
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
let touch = touchForeignPtr exprFPl
return $ Just (Expr c_expr1 touch,Expr c_expr2 touch,Expr c_expr3 touch)
else do gu_pool_free exprPl
return Nothing
showTriple :: Expr -> Expr -> Expr -> String
showTriple (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
unsafePerformIO $
withGuPool $ \tmpPl ->
withTriple $ \triple -> do
(sb,out) <- newOut tmpPl
let printCtxt = nullPtr
exn <- gu_new_exn tmpPl
pokeElemOff triple 0 expr1
pokeElemOff triple 1 expr2
pokeElemOff triple 2 expr3
pgf_print_expr_tuple 3 triple printCtxt out exn
touch1 >> touch2 >> touch3
s <- gu_string_buf_freeze sb tmpPl
peekUtf8CString s
insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId
insertTriple (SG sg) (Expr expr1 touch1) (Expr expr2 touch2) (Expr expr3 touch3) =
withGuPool $ \tmpPl ->
withTriple $ \triple -> do
exn <- gu_new_exn tmpPl
pokeElemOff triple 0 expr1
pokeElemOff triple 1 expr2
pokeElemOff triple 2 expr3
id <- sg_insert_triple sg triple exn
touch1 >> touch2 >> touch3
handle_sg_exn exn
return id
getTriple :: SG -> SgId -> IO (Maybe (Expr,Expr,Expr))
getTriple (SG sg) id = do
exprPl <- gu_new_pool
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
let touch = touchForeignPtr exprFPl
withGuPool $ \tmpPl ->
withTriple $ \triple -> do
exn <- gu_new_exn tmpPl
res <- sg_get_triple sg id triple exprPl exn
handle_sg_exn exn
if res /= 0
then do c_expr1 <- peekElemOff triple 0
c_expr2 <- peekElemOff triple 1
c_expr3 <- peekElemOff triple 2
return (Just (Expr c_expr1 touch
,Expr c_expr2 touch
,Expr c_expr3 touch
))
else do touch
return Nothing
queryTriple :: SG -> Maybe Expr -> Maybe Expr -> Maybe Expr -> IO [(SgId,Expr,Expr,Expr)]
queryTriple (SG sg) mb_expr1 mb_expr2 mb_expr3 =
withGuPool $ \tmpPl ->
withTriple $ \triple -> do
exn <- gu_new_exn tmpPl
pokeElemOff triple 0 (toCExpr mb_expr1)
pokeElemOff triple 1 (toCExpr mb_expr2)
pokeElemOff triple 2 (toCExpr mb_expr3)
res <- sg_query_triple sg triple exn
handle_sg_exn exn
unsafeInterleaveIO (fetchResults res)
where
toCExpr Nothing = nullPtr
toCExpr (Just (Expr expr _)) = expr
fromCExpr c_expr touch Nothing = Expr c_expr touch
fromCExpr c_expr touch (Just e) = e
fetchResults res = do
exprPl <- gu_new_pool
alloca $ \pKey ->
withGuPool $ \tmpPl ->
withTriple $ \triple -> do
exn <- gu_new_exn tmpPl
r <- sg_triple_result_fetch res pKey triple exprPl exn
failed <- gu_exn_is_raised exn
if failed
then do gu_pool_free exprPl
sg_triple_result_close res exn
handle_sg_exn exn
return []
else if r == 0
then do gu_pool_free exprPl
sg_triple_result_close res exn
return []
else do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
let touch = touchForeignPtr exprFPl
c_expr1 <- peekElemOff triple 0
c_expr2 <- peekElemOff triple 1
c_expr3 <- peekElemOff triple 2
key <- peek pKey
rest <- unsafeInterleaveIO (fetchResults res)
return ((key,fromCExpr c_expr1 touch mb_expr1
,fromCExpr c_expr2 touch mb_expr2
,fromCExpr c_expr3 touch mb_expr3) : rest)
query :: SG -> String -> IO [[Expr]]
query (SG sg) str =
withGuPool $ \tmpPl ->
do c_str <- newUtf8CString str tmpPl
guin <- gu_string_in c_str tmpPl
exn <- gu_new_exn tmpPl
seq <- pgf_read_expr_matrix guin 3 tmpPl exn
if seq /= nullPtr
then do count <- (#peek GuSeq, len) seq
q <- sg_query sg (count `div` 3) (seq `plusPtr` (#offset GuSeq, data)) exn
handle_sg_exn exn
n_cols <- sg_query_result_columns q
unsafeInterleaveIO (fetchResults q n_cols)
else return []
where
fetchResults q n_cols =
withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
pExprs <- gu_malloc tmpPl ((#size PgfExpr) * n_cols)
exprPl <- gu_new_pool
res <- sg_query_result_fetch q pExprs exprPl exn
failed <- gu_exn_is_raised exn
if failed
then do gu_pool_free exprPl
sg_query_result_close q exn
handle_sg_exn exn
return []
else if res /= 0
then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
let touch = touchForeignPtr exprFPl
row <- fmap (map (flip Expr touch)) $ peekArray (fromIntegral n_cols) pExprs
rows <- unsafeInterleaveIO (fetchResults q n_cols)
return (row:rows)
else do gu_pool_free exprPl
sg_query_result_close q exn
return []
-----------------------------------------------------------------------
-- Exceptions
newtype SGError = SGError String
deriving (Show, Typeable)
instance Exception SGError
handle_sg_exn exn = do
failed <- gu_exn_is_raised exn
if failed
then do is_sgerr <- gu_exn_caught exn gu_exn_type_SgError
if is_sgerr
then do c_msg <- (#peek GuExn, data.data) exn
msg <- peekUtf8CString c_msg
throwIO (SGError msg)
else throwIO (SGError "Unknown database error")
else return ()
-----------------------------------------------------------------------

84
src/runtime/haskell/SG/FFI.hs
View File

@@ -1,84 +0,0 @@
{-# LANGUAGE ForeignFunctionInterface, MagicHash #-}
module SG.FFI where
import Foreign
import Foreign.C
import PGF2.FFI
import GHC.Ptr
import Data.Int
data SgSG
data SgQueryExprResult
data SgTripleResult
data SgQueryResult
type SgId = Int64
foreign import ccall "sg/sg.h sg_open"
sg_open :: CString -> Ptr GuExn -> IO (Ptr SgSG)
foreign import ccall "sg/sg.h sg_close"
sg_close :: Ptr SgSG -> Ptr GuExn -> IO ()
foreign import ccall "sg/sg.h sg_begin_trans"
sg_begin_trans :: Ptr SgSG -> Ptr GuExn -> IO ()
foreign import ccall "sg/sg.h sg_commit"
sg_commit :: Ptr SgSG -> Ptr GuExn -> IO ()
foreign import ccall "sg/sg.h sg_rollback"
sg_rollback :: Ptr SgSG -> Ptr GuExn -> IO ()
foreign import ccall "sg/sg.h sg_insert_expr"
sg_insert_expr :: Ptr SgSG -> PgfExpr -> CInt -> Ptr GuExn -> IO SgId
foreign import ccall "sg/sg.h sg_get_expr"
sg_get_expr :: Ptr SgSG -> SgId -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr
foreign import ccall "sg/sg.h sg_query_expr"
sg_query_expr :: Ptr SgSG -> PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO (Ptr SgQueryExprResult)
foreign import ccall "sg/sg.h sg_query_next"
sg_query_next :: Ptr SgSG -> Ptr SgQueryExprResult -> Ptr SgId -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr
foreign import ccall "sg/sg.h sg_query_close"
sg_query_close :: Ptr SgSG -> Ptr SgQueryExprResult -> Ptr GuExn -> IO ()
foreign import ccall "sg/sg.h sg_update_fts_index"
sg_update_fts_index :: Ptr SgSG -> Ptr PgfPGF -> Ptr GuExn -> IO ()
foreign import ccall "sg/sg.h sg_query_linearization"
sg_query_linearization :: Ptr SgSG -> CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq)
foreign import ccall "sg/sg.h sg_insert_triple"
sg_insert_triple :: Ptr SgSG -> SgTriple -> Ptr GuExn -> IO SgId
foreign import ccall "sg/sg.h sg_get_triple"
sg_get_triple :: Ptr SgSG -> SgId -> SgTriple -> Ptr GuPool -> Ptr GuExn -> IO CInt
foreign import ccall "sg/sg.h sg_query_triple"
sg_query_triple :: Ptr SgSG -> SgTriple -> Ptr GuExn -> IO (Ptr SgTripleResult)
foreign import ccall "sg/sg.h sg_triple_result_fetch"
sg_triple_result_fetch :: Ptr SgTripleResult -> Ptr SgId -> SgTriple -> Ptr GuPool -> Ptr GuExn -> IO CInt
foreign import ccall "sg/sg.h sg_triple_result_close"
sg_triple_result_close :: Ptr SgTripleResult -> Ptr GuExn -> IO ()
foreign import ccall "sg/sg.h sg_query"
sg_query :: Ptr SgSG -> CSizeT -> Ptr PgfExpr -> Ptr GuExn -> IO (Ptr SgQueryResult)
foreign import ccall "sg/sg.h sg_query_result_columns"
sg_query_result_columns :: Ptr SgQueryResult -> IO CSizeT
foreign import ccall "sg/sg.h sg_query_result_fetch"
sg_query_result_fetch :: Ptr SgQueryResult -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt
foreign import ccall "sg/sg.h sg_query_result_close"
sg_query_result_close :: Ptr SgQueryResult -> Ptr GuExn -> IO ()
type SgTriple = Ptr PgfExpr
withTriple :: (SgTriple -> IO a) -> IO a
withTriple = allocaArray 3
gu_exn_type_SgError = Ptr "SgError"# :: CString

12
src/runtime/haskell/pgf2.cabal
View File

@@ -14,10 +14,10 @@ extra-source-files: README
cabal-version: >=1.10
library
exposed-modules: PGF2, PGF2.Internal, SG,
exposed-modules: PGF2, PGF2.Internal,
-- backwards compatibility API:
PGF
other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI
other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type
build-depends: base >=4.3, containers, pretty, array, random
-- hs-source-dirs:
default-language: Haskell2010
@@ -27,11 +27,3 @@ library
cc-options: -std=c99
default-language: Haskell2010
c-sources: utils.c
executable pgf-shell
main-is: pgf-shell.hs
hs-source-dirs: examples
build-depends: base, pgf2, containers, mtl, lifted-base
default-language: Haskell2010
if impl(ghc>=7.0)
ghc-options: -rtsopts

3
src/runtime/haskell/stack-ghc7.10.3.yaml Normal file
View File

@@ -0,0 +1,3 @@
resolver: lts-6.35 # ghc 7.10.3
allow-newer: true

1
src/runtime/haskell/stack-ghc8.0.2.yaml Normal file
View File

@@ -0,0 +1 @@
resolver: lts-9.21 # ghc 8.0.2

1
src/runtime/haskell/stack-ghc8.10.4.yaml Normal file
View File

@@ -0,0 +1 @@
resolver: lts-18.0 # ghc 8.10.4

31
src/runtime/haskell/stack-haddock-upload.sh Executable file
View File

@@ -0,0 +1,31 @@
#!/bin/bash
# Author: Dimitri Sabadie <dimitri.sabadie@gmail.com>
# 2015
if [ $# -lt 2 ]; then
echo "Usage: ./stack-haddock-upload.sh NAME VERSION"
exit 1
fi
dist=`stack path --dist-dir --stack-yaml ./stack.yaml 2> /dev/null`
echo -e "\033[1;36mGenerating documentation...\033[0m"
stack haddock 2> /dev/null
if [ "$?" -eq "0" ]; then
docdir=$dist/doc/html
cd $docdir || exit
doc=$1-$2-docs
echo -e "Compressing documentation from \033[1;34m$docdir\033[0m for \033[1;35m$1\033[0m-\033[1;33m$2\033[1;30m"
cp -r $1 $doc
tar -c -v -z --format=ustar -f $doc.tar.gz $doc
echo -e "\033[1;32mUploading to Hackage...\033[0m"
read -p "Hackage username: " username
read -p "Hackage password: " -s password
echo ""
curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "@$doc.tar.gz" "https://$username:$password@hackage.haskell.org/package/$1-$2/docs"
exit $?
else
echo -e "\033[1;31mNot in a stack-powered project\033[0m"
fi

3
src/runtime/haskell/stack.yaml Normal file
View File

@@ -0,0 +1,3 @@
# This is mainly here so that I can run `stack sdist` for uploading to Hackage
resolver: lts-12.26 # ghc 8.4.4

6
src/runtime/haskell/utils.c
View File

@@ -4,7 +4,7 @@
typedef struct {
PgfLiteralCallback callback;
PgfExprProb* (*match)(size_t lin_idx, size_t* poffset,
PgfExprProb* (*match)(GuString ann, size_t* poffset,
GuPool *out_pool);
GuFinalizer fin;
} HSPgfLiteralCallback;
@@ -37,7 +37,7 @@ hspgf_hs2offset(GuString sentence, size_t hs_offset)
static PgfExprProb*
hspgf_match_callback(PgfLiteralCallback* self, PgfConcr* concr,
size_t lin_idx,
GuString ann,
GuString sentence, size_t* poffset,
GuPool *out_pool)
{
@@ -46,7 +46,7 @@ hspgf_match_callback(PgfLiteralCallback* self, PgfConcr* concr,
size_t hs_offset =
hspgf_offset2hs(sentence, *poffset);
PgfExprProb* ep =
callback->match(lin_idx, &hs_offset, out_pool);
callback->match(ann, &hs_offset, out_pool);
*poffset = hspgf_hs2offset(sentence, hs_offset);
return ep;