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/CHANGELOG.md22
-rw-r--r--src/runtime/haskell-bind/HACKAGE.md10
-rw-r--r--src/runtime/haskell-bind/LICENSE165
-rw-r--r--src/runtime/haskell-bind/PGF.hs3
-rw-r--r--src/runtime/haskell-bind/PGF/Internal.hs1
-rw-r--r--src/runtime/haskell-bind/PGF2.hsc145
-rw-r--r--src/runtime/haskell-bind/PGF2/FFI.hsc20
-rw-r--r--src/runtime/haskell-bind/README26
-rw-r--r--src/runtime/haskell-bind/README.md56
-rw-r--r--src/runtime/haskell-bind/SG.hsc349
-rw-r--r--src/runtime/haskell-bind/SG/FFI.hs84
-rw-r--r--src/runtime/haskell-bind/pgf2.cabal77
-rwxr-xr-xsrc/runtime/haskell-bind/stack-haddock-upload.sh31
-rw-r--r--src/runtime/haskell-bind/stack.yaml3
14 files changed, 440 insertions, 552 deletions
diff --git a/src/runtime/haskell-bind/CHANGELOG.md b/src/runtime/haskell-bind/CHANGELOG.md
new file mode 100644
index 000000000..570c7fd73
--- /dev/null
+++ b/src/runtime/haskell-bind/CHANGELOG.md
@@ -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.
diff --git a/src/runtime/haskell-bind/HACKAGE.md b/src/runtime/haskell-bind/HACKAGE.md
new file mode 100644
index 000000000..d931ef8f9
--- /dev/null
+++ b/src/runtime/haskell-bind/HACKAGE.md
@@ -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`)
diff --git a/src/runtime/haskell-bind/LICENSE b/src/runtime/haskell-bind/LICENSE
new file mode 100644
index 000000000..0a041280b
--- /dev/null
+++ b/src/runtime/haskell-bind/LICENSE
@@ -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.
diff --git a/src/runtime/haskell-bind/PGF.hs b/src/runtime/haskell-bind/PGF.hs
deleted file mode 100644
index 8aeca7ab8..000000000
--- a/src/runtime/haskell-bind/PGF.hs
+++ /dev/null
@@ -1,3 +0,0 @@
-module PGF(module PGF2) where
-
-import PGF2
diff --git a/src/runtime/haskell-bind/PGF/Internal.hs b/src/runtime/haskell-bind/PGF/Internal.hs
deleted file mode 100644
index e8193b788..000000000
--- a/src/runtime/haskell-bind/PGF/Internal.hs
+++ /dev/null
@@ -1 +0,0 @@
-module PGF.Internal where
diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 4b41a7471..38fae67ef 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -43,30 +43,28 @@ module PGF2 (-- * PGF
mkCId,
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,bracketedLinearizeAll,
FId, BracketedString(..), showBracketedString, flattenBracketedString,
printName, categoryFields,
-
alignWords,
-- ** Parsing
ParseOutput(..), parse, parseWithHeuristics,
parseToChart, PArg(..),
+ complete,
-- ** Sentence Lookup
lookupSentence,
-- ** Generation
@@ -180,7 +178,7 @@ languageCode c = unsafePerformIO (peekUtf8CString =<< pgf_language_code (concr c
-- | 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 _) =
@@ -433,6 +431,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
@@ -468,21 +467,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]
@@ -540,12 +539,12 @@ lookupCohorts lang@(Concr concr master) sent =
return ((start,tok,ans,end):cohs)
filterBest :: [(Int,String,[MorphoAnalysis],Int)] -> [(Int,String,[MorphoAnalysis],Int)]
-filterBest ans =
+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 =
+ iterate v0 ((_,v,conf, []):old) new res =
case compare v0 v of
LT -> res
EQ -> iterate v0 old new (merge conf res)
@@ -648,7 +647,7 @@ getAnalysis ref self c_lemma c_anal prob exn = do
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 a -- ^ If the parsing and the type checking are successful
+ | 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.
@@ -658,9 +657,9 @@ 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, String -> Int -> Maybe (Expr,Float,Int))]
-- ^ a list of callbacks for literal categories.
@@ -714,9 +713,9 @@ parseWithHeuristics lang (Type ctype touchType) sent heuristic callbacks =
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
+ -> 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.
@@ -726,7 +725,7 @@ parseToChart :: Concr -- ^ the language with which we parse
-- 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)]))
+ -> 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
@@ -776,19 +775,23 @@ parseToChart lang (Type ctype touchType) sent heuristic callbacks roots =
c_total_cats <- (#peek PgfConcr, total_cats) (concr lang)
if Map.member fid chart || fid < c_total_cats
then return (fid,chart)
- else do range <- get_range c_ccat >>= peekSequence peekRange (#size PgfParseRange)
+ 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,[]) chart)
+ 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) chart)
+ (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
+ (ps1,chart) <- deRef (peekProduction chart) ptr
(ps2,chart) <- peekProductions chart (len-1) (ptr `plusPtr` (#size GuVariant))
return (ps1++ps2,chart)
@@ -806,13 +809,15 @@ parseToChart lang (Type ctype touchType) sent heuristic callbacks roots =
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 [] snd (Map.lookup fid chart),chart) }
+ 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
@@ -852,16 +857,7 @@ mkCallbacksMap concr callbacks pool = do
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
@@ -888,7 +884,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)
@@ -976,6 +972,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, CId, CId, 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, CId, CId, 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 $
@@ -1049,7 +1106,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
_ -> []
@@ -1140,7 +1197,7 @@ data BracketedString
-- 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
@@ -1150,7 +1207,7 @@ data BracketedString
-- The second 'CId' 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
@@ -1168,7 +1225,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
@@ -1194,7 +1251,7 @@ bracketedLinearize lang e = unsafePerformIO $
bracketedLinearizeAll :: Concr -> Expr -> [[BracketedString]]
bracketedLinearizeAll 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
@@ -1469,7 +1526,7 @@ type LiteralCallback =
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 =
diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc
index b348f5012..16f9ad46d 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hsc
+++ b/src/runtime/haskell-bind/PGF2/FFI.hsc
@@ -103,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
@@ -241,7 +241,7 @@ newSequence elem_size pokeElem values pool = do
type FId = Int
data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
-peekFId :: Ptr a -> IO FId
+peekFId :: Ptr a -> IO FId
peekFId c_ccat = do
c_fid <- (#peek PgfCCat, fid) c_ccat
return (fromIntegral (c_fid :: CInt))
@@ -256,6 +256,7 @@ data PgfApplication
data PgfConcr
type PgfExpr = Ptr ()
data PgfExprProb
+data PgfTokenProb
data PgfExprParser
data PgfFullFormEntry
data PgfMorphoCallback
@@ -422,6 +423,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 ()
@@ -513,9 +517,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 ()
@@ -531,12 +532,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
@@ -557,3 +552,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
diff --git a/src/runtime/haskell-bind/README b/src/runtime/haskell-bind/README
deleted file mode 100644
index 4782c2d37..000000000
--- a/src/runtime/haskell-bind/README
+++ /dev/null
@@ -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)
diff --git a/src/runtime/haskell-bind/README.md b/src/runtime/haskell-bind/README.md
new file mode 100644
index 000000000..1cb68df65
--- /dev/null
+++ b/src/runtime/haskell-bind/README.md
@@ -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
+```
diff --git a/src/runtime/haskell-bind/SG.hsc b/src/runtime/haskell-bind/SG.hsc
deleted file mode 100644
index 791abc767..000000000
--- a/src/runtime/haskell-bind/SG.hsc
+++ /dev/null
@@ -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 ()
-
------------------------------------------------------------------------
diff --git a/src/runtime/haskell-bind/SG/FFI.hs b/src/runtime/haskell-bind/SG/FFI.hs
deleted file mode 100644
index ef1b06de8..000000000
--- a/src/runtime/haskell-bind/SG/FFI.hs
+++ /dev/null
@@ -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
diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal
index 4022f0b9b..c8d5d8c6c 100644
--- a/src/runtime/haskell-bind/pgf2.cabal
+++ b/src/runtime/haskell-bind/pgf2.cabal
@@ -1,37 +1,46 @@
-name: pgf2
-version: 0.1.0.0
--- synopsis:
--- description:
-homepage: http://www.grammaticalframework.org
-license: LGPL-3
---license-file: LICENSE
-author: Krasimir Angelov, Inari
-maintainer:
--- copyright:
-category: Language
-build-type: Simple
-extra-source-files: README
-cabal-version: >=1.10
+name: pgf2
+version: 1.3.0
+synopsis: Bindings to the C version of the PGF runtime
+description:
+ GF, Grammatical Framework, is a programming language for multilingual grammar applications.
+ GF grammars are compiled into Portable Grammar Format (PGF) which can be used with the PGF runtime, written in C.
+ This package provides Haskell bindings to that runtime.
+homepage: https://www.grammaticalframework.org
+license: LGPL-3
+license-file: LICENSE
+author: Krasimir Angelov
+category: Natural Language Processing
+build-type: Simple
+extra-source-files: CHANGELOG.md, README.md
+cabal-version: >=1.10
library
- exposed-modules: PGF2, PGF2.Internal, SG
- -- backwards compatibility API:
- --, PGF, PGF.Internal
- other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI
- build-depends: base >=4.3,
- containers, pretty
- -- hs-source-dirs:
- default-language: Haskell2010
- build-tools: hsc2hs
+ exposed-modules:
+ PGF2,
+ PGF2.Internal
+ other-modules:
+ PGF2.FFI,
+ PGF2.Expr,
+ PGF2.Type
+ build-depends:
+ base >=4.3 && <5,
+ containers,
+ pretty
+ default-language: Haskell2010
+ build-tools: hsc2hs
+ extra-libraries: pgf gu
+ cc-options: -std=c99
+ c-sources: utils.c
- extra-libraries: sg pgf gu
- cc-options: -std=c99
- 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
+-- executable pgf-shell
+-- main-is: pgf-shell.hs
+-- hs-source-dirs: examples
+-- build-depends:
+-- base,
+-- containers,
+-- lifted-base,
+-- mtl,
+-- pgf2
+-- default-language: Haskell2010
+-- if impl(ghc>=7.0)
+-- ghc-options: -rtsopts
diff --git a/src/runtime/haskell-bind/stack-haddock-upload.sh b/src/runtime/haskell-bind/stack-haddock-upload.sh
new file mode 100755
index 000000000..47333bf38
--- /dev/null
+++ b/src/runtime/haskell-bind/stack-haddock-upload.sh
@@ -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
diff --git a/src/runtime/haskell-bind/stack.yaml b/src/runtime/haskell-bind/stack.yaml
new file mode 100644
index 000000000..3b1a3092b
--- /dev/null
+++ b/src/runtime/haskell-bind/stack.yaml
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2026-08-03 16:20:00 +0000