diff --git a/src/runtime/c/pgf.cxx b/src/runtime/c/pgf.cxx index 4ebbbad75..3af02ae47 100644 --- a/src/runtime/c/pgf.cxx +++ b/src/runtime/c/pgf.cxx @@ -1,11 +1,21 @@ #include "data.h" #include "reader.h" +static void +pgf_exn_clear(PgfExn* err) +{ + err->type = PGF_EXN_NONE; + err->code = 0; + err->msg = NULL; +} + PGF_API PgfPGF *pgf_read(const char* fpath, PgfExn* err) { PgfPGF *pgf = NULL; + pgf_exn_clear(err); + try { std::string fpath_n = fpath; size_t len = fpath_n.length(); @@ -30,11 +40,11 @@ PgfPGF *pgf_read(const char* fpath, PgfExn* err) return pgf; } catch (std::system_error& e) { - err->type = "system_error"; - err->msg = NULL; + err->type = PGF_EXN_SYSTEM_ERROR; + err->code = e.code().value(); } catch (pgf_error& e) { - err->type = "pgf_error"; - err->msg = e.what(); + err->type = PGF_EXN_PGF_ERROR; + err->msg = strdup(e.what()); } if (pgf != NULL) @@ -49,3 +59,9 @@ void PgfPGF::set_root() { root->minor_version = minor_version; DB::set_root(root); } + +PGF_API +void pgf_free(PgfPGF *pgf) +{ + delete pgf; +} diff --git a/src/runtime/c/pgf.h b/src/runtime/c/pgf.h index d96fb911d..8929f274c 100644 --- a/src/runtime/c/pgf.h +++ b/src/runtime/c/pgf.h @@ -39,12 +39,22 @@ typedef struct PgfPGF PgfPGF; +typedef enum { + PGF_EXN_NONE, + PGF_EXN_SYSTEM_ERROR, + PGF_EXN_PGF_ERROR +} PgfExnType; + typedef struct { - const char *type; + PgfExnType type; + int code; const char *msg; } PgfExn; PGF_API_DECL PgfPGF *pgf_read(const char* fpath, PgfExn* err); +PGF_API_DECL +void pgf_free(PgfPGF *pgf); + #endif // PGF_H_ diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index d4aec81b6..7000e01ee 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -1,283 +1,6 @@ -module PGF (PGF2.PGF, readPGF, showPGF, - abstractName, - - CId, mkCId, wildCId, showCId, readCId, - - categories, categoryContext, categoryProbability, - functions, functionsByCat, functionType, functionIsDataCon, browse, - - PGF2.Expr,Tree,showExpr,PGF2.readExpr,pExpr,pIdent, - mkAbs,unAbs, - mkApp,unApp,unapply, - PGF2.mkStr,PGF2.unStr, - PGF2.mkInt,PGF2.unInt, - PGF2.mkFloat,PGF2.unFloat, - PGF2.mkMeta,PGF2.unMeta, - PGF2.exprSize, exprFunctions,PGF2.exprSubstitute, - compute, - rankTreesByProbs,treeProbability, - - TcError, ppTcError, inferExpr, checkType, - - PGF2.Type, PGF2.Hypo, showType, showContext, PGF2.readType, - mkType, unType, - - PGF2.Token, PGF2.FId, - - Language, readLanguage, showLanguage, - languages, startCat, languageCode, - linearize, bracketedLinearize, tabularLinearizes, showBracketedString, - ParseOutput(..), parse, parse_, complete, - PGF2.BracketedString(..), PGF2.flattenBracketedString, - hasLinearization, - showPrintName, - - Morpho, buildMorpho, - lookupMorpho, isInMorpho, morphoMissing, morphoKnown, fullFormLexicon, - - Labels, getDepLabels, CncLabels, getCncDepLabels, - - generateAllDepth, generateRandom, generateRandomFrom, generateRandomDepth, generateRandomFromDepth, - generateFromDepth, - - PGF2.GraphvizOptions(..), - graphvizAbstractTree, graphvizParseTree, graphvizAlignment, graphvizDependencyTree, graphvizParseTreeDep, - - -- * Tries - ATree(..),Trie(..),toATree,toTrie, - - readProbabilitiesFromFile, - - groupResults, conlls2latexDoc, gizaAlignment +module PGF (PGF2.PGF, readPGF ) where import qualified PGF2 as PGF2 -import qualified PGF2.Internal as PGF2 -import qualified Data.Map as Map -import qualified Text.ParserCombinators.ReadP as RP -import Data.List(sortBy) -import Text.PrettyPrint(text) -import Data.Char(isDigit) - -newtype CId = CId String deriving (Show,Read,Eq,Ord) - -type Language = CId - -lookConcr gr (CId lang) = - case Map.lookup lang (PGF2.languages gr) of - Just cnc -> cnc - Nothing -> error "Unknown language" readPGF = PGF2.readPGF - -showPGF gr = PGF2.showPGF gr - -readLanguage = readCId -showLanguage (CId s) = s - -startCat = PGF2.startCat -languageCode pgf lang = Just (PGF2.languageCode (lookConcr pgf lang)) - -abstractName gr = CId (PGF2.abstractName gr) - -categories gr = map CId (PGF2.categories gr) -categoryContext gr (CId c) = PGF2.categoryContext gr c -categoryProbability gr (CId c) = PGF2.categoryProbability gr c - -functions gr = map CId (PGF2.functions gr) -functionsByCat gr (CId c) = map CId (PGF2.functionsByCat gr c) -functionType gr (CId f) = PGF2.functionType gr f -functionIsDataCon gr (CId f) = PGF2.functionIsDataCon gr f - -type Tree = PGF2.Expr -type Labels = Map.Map CId [String] -type CncLabels = [(String, String -> Maybe (String -> String,String,String))] - - -mkCId x = CId x -wildCId = CId "_" -showCId (CId x) = x -readCId s = Just (CId s) - -showExpr xs e = PGF2.showExpr [x | CId x <- xs] e - -pExpr = RP.readS_to_P PGF2.pExpr -pIdent = RP.readS_to_P PGF2.pIdent - -mkAbs bind_type (CId var) e = PGF2.mkAbs bind_type var e -unAbs e = case PGF2.unAbs e of - Just (bind_type, var, e) -> Just (bind_type, CId var, e) - Nothing -> Nothing - -mkApp (CId f) es = PGF2.mkApp f es -unApp e = case PGF2.unApp e of - Just (f,es) -> Just (CId f,es) - Nothing -> Nothing - -unapply = PGF2.unapply - -instance Read PGF2.Expr where - readsPrec _ s = case PGF2.readExpr s of - Just e -> [(e,"")] - Nothing -> [] - -showType xs ty = PGF2.showType [x | CId x <- xs] ty -showContext xs hypos = PGF2.showContext [x | CId x <- xs] hypos - -mkType hypos (CId var) es = PGF2.mkType [(bt,var,ty) | (bt,CId var,ty) <- hypos] var es -unType ty = case PGF2.unType ty of - (hypos,var,es) -> ([(bt,CId var,ty) | (bt,var,ty) <- hypos],CId var,es) - -linearize pgf lang e = PGF2.linearize (lookConcr pgf lang) e -bracketedLinearize pgf lang e = PGF2.bracketedLinearize (lookConcr pgf lang) e -tabularLinearizes pgf lang e = [PGF2.tabularLinearize (lookConcr pgf lang) e] -showBracketedString = PGF2.showBracketedString - -type TcError = String - --- | This data type encodes the different outcomes which you could get from the parser. -data ParseOutput - = ParseFailed Int -- ^ The integer is the position in number of tokens where the parser failed. - | TypeError [(PGF2.FId,TcError)] -- ^ The parsing was successful but none of the trees is type correct. - -- The forest id ('FId') points to the bracketed string from the parser - -- where the type checking failed. More than one error is returned - -- if there are many analizes for some phrase but they all are not type correct. - | ParseOk [Tree] -- ^ If the parsing and the type checking are successful we get a list of abstract syntax trees. - -- The list should be non-empty. - | ParseIncomplete -- ^ The sentence is not complete. Only partial output is produced - -parse pgf lang cat s = - case PGF2.parse (lookConcr pgf lang) cat s of - PGF2.ParseOk ts -> map fst ts - _ -> [] - -parse_ pgf lang cat dp s = - case PGF2.parse (lookConcr pgf lang) cat s of - PGF2.ParseFailed pos _ -> (ParseFailed pos, PGF2.Leaf s) - PGF2.ParseOk ts -> (ParseOk (map fst ts), PGF2.Leaf s) - PGF2.ParseIncomplete -> (ParseIncomplete, PGF2.Leaf s) - -complete 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 - -ppTcError s = s - -inferExpr gr e = - case PGF2.inferExpr gr e of - Right res -> Right res - Left msg -> Left (text msg) - -checkType gr ty = - case PGF2.checkType gr ty of - Right res -> Right res - Left msg -> Left (text msg) - -showPrintName pgf lang (CId f) = - case PGF2.printName (lookConcr pgf lang) f of - Just n -> n - Nothing -> f - -getDepLabels :: String -> Labels -getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map words (lines s)] - -getCncDepLabels :: String -> CncLabels -getCncDepLabels = PGF2.getCncDepLabels - -generateAllDepth gr ty _ = map fst (PGF2.generateAll gr ty) -generateFromDepth = error "generateFromDepth is not implemented" -generateRandom = error "generateRandom is not implemented" -generateRandomFrom = error "generateRandomFrom is not implemented" -generateRandomDepth = error "generateRandomDepth is not implemented" -generateRandomFromDepth = error "generateRandomFromDepth is not implemented" - -exprFunctions e = [CId f | f <- PGF2.exprFunctions e] - -compute = error "compute is not implemented" - --- | rank from highest to lowest probability -rankTreesByProbs :: PGF2.PGF -> [PGF2.Expr] -> [(PGF2.Expr,Double)] -rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p) - [(t, realToFrac (PGF2.treeProbability pgf t)) | t <- ts] - -treeProbability = PGF2.treeProbability - -languages pgf = fmap CId (Map.keys (PGF2.languages pgf)) - -type Morpho = PGF2.Concr - -buildMorpho pgf lang = lookConcr pgf lang -lookupMorpho cnc w = [(CId lemma,an) | (lemma,an,_) <- PGF2.lookupMorpho cnc w] -isInMorpho cnc w = not (null (PGF2.lookupMorpho cnc w)) -fullFormLexicon cnc = [(w, [(CId fun,an) | (fun,an,_) <- analyses]) | (w, analyses) <- PGF2.fullFormLexicon cnc] - -graphvizAbstractTree pgf (funs,cats) = PGF2.graphvizAbstractTree pgf PGF2.graphvizDefaults{PGF2.noFun=not funs,PGF2.noCat=not cats} -graphvizParseTree pgf lang = PGF2.graphvizParseTree (lookConcr pgf lang) -graphvizAlignment pgf langs = PGF2.graphvizWordAlignment (map (lookConcr pgf) langs) PGF2.graphvizDefaults -graphvizDependencyTree format debug lbls cnclbls pgf lang e = - let to_lbls' lbls = Map.fromList [(id,xs) | (CId id,xs) <- Map.toList lbls] - in PGF2.graphvizDependencyTree format debug (fmap to_lbls' lbls) cnclbls (lookConcr pgf lang) e -graphvizParseTreeDep = error "graphvizParseTreeDep is not implemented" - -browse :: PGF2.PGF -> CId -> Maybe (String,[CId],[CId]) -browse = error "browse is not implemented" - --- | A type for plain applicative trees -data ATree t = Other t | App CId [ATree t] deriving Show -data Trie = Oth Tree | Ap CId [[Trie ]] deriving Show --- ^ A type for tries of plain applicative trees - --- | Convert a 'Tree' to an 'ATree' -toATree :: Tree -> ATree Tree -toATree e = maybe (Other e) app (PGF2.unApp e) - where - app (f,es) = App (mkCId f) (map toATree es) - --- | Combine a list of trees into a trie -toTrie = combines . map ((:[]) . singleton) - where - singleton t = case t of - Other e -> Oth e - App f ts -> Ap f [map singleton ts] - - combines [] = [] - combines (ts:tss) = ts1:combines tss2 - where - (ts1,tss2) = combines2 [] tss ts - combines2 ots [] ts1 = (ts1,reverse ots) - combines2 ots (ts2:tss) ts1 = - maybe (combines2 (ts2:ots) tss ts1) (combines2 ots tss) (combine ts1 ts2) - - combine ts us = mapM combine2 (zip ts us) - where - combine2 (Ap f ts,Ap g us) | f==g = Just (Ap f (combines (ts++us))) - combine2 _ = Nothing - -readProbabilitiesFromFile :: FilePath -> IO (Map.Map CId Double) -readProbabilitiesFromFile fpath = do - s <- readFile fpath - return $ Map.fromList [(mkCId f,read p) | f:p:_ <- map words (lines s)] - -groupResults :: [[(Language,String)]] -> [(Language,[String])] -groupResults = Map.toList . foldr more Map.empty . start . concat - where - start ls = [(l,[s]) | (l,s) <- ls] - more (l,s) = - Map.insertWith (\ [x] xs -> if elem x xs then xs else (x : xs)) l s - -conlls2latexDoc = error "conlls2latexDoc is not implemented" - - -morphoMissing :: Morpho -> [String] -> [String] -morphoMissing = morphoClassify False - -morphoKnown :: Morpho -> [String] -> [String] -morphoKnown = morphoClassify True - -morphoClassify :: Bool -> Morpho -> [String] -> [String] -morphoClassify k mo ws = [w | w <- ws, k /= null (lookupMorpho mo w), notLiteral w] where - notLiteral w = not (all isDigit w) ---- should be defined somewhere - -gizaAlignment = error "gizaAlignment is not implemented" diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index b4d6d9851..5b7eaba22 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -13,1961 +13,35 @@ -- programs ------------------------------------------------- -#include -#include -#include -#include -#include - module PGF2 (-- * PGF - PGF,readPGF,showPGF, - - -- * Abstract syntax - AbsName,abstractName, - -- ** Categories - Cat,categories,categoryContext,categoryProbability, - -- ** Functions - Fun, functions, functionsByCat, - functionType, functionIsDataCon, hasLinearization, - -- ** Expressions - Expr,showExpr,readExpr,pExpr,pIdent, - mkAbs,unAbs, - mkApp,unApp,unapply, - mkStr,unStr, - mkInt,unInt, - mkFloat,unFloat, - 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,bracketedLinearizeAll, - FId, BracketedString(..), showBracketedString, flattenBracketedString, - printName, categoryFields, - alignWords, gizaAlignment, - -- ** Parsing - ParseOutput(..), parse, parseWithHeuristics, - parseToChart, PArg(..), - complete, - -- ** Sentence Lookup - lookupSentence, - - -- ** Generation - generateAll, generateAllFrom, - generateRandom, generateRandomFrom, - - -- ** Morphological Analysis - MorphoAnalysis, lookupMorpho, lookupCohorts, fullFormLexicon, - filterBest, filterLongest, - -- ** Visualizations - GraphvizOptions(..), graphvizDefaults, - graphvizAbstractTree, graphvizParseTree, - Labels, getDepLabels, - graphvizDependencyTree, conlls2latexDoc, getCncDepLabels, - graphvizWordAlignment, - - -- * Exceptions - PGFError(..), - - -- * Grammar specific callbacks - LiteralCallback,literalCallbacks, - - -- * Auxiliaries - readProbabilitiesFromFile + PGF,readPGF ) where -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 import PGF2.FFI -import Foreign hiding ( Pool, newPool, unsafePerformIO ) +import Foreign import Foreign.C import Data.Typeable import qualified Data.Map as Map -import Data.IORef -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. --- --- A Concr retains its PGF in a field in order to retain a reference to --- the foreign pointer in case if the application still has a reference --- to Concr but has lost its reference to PGF. +#include - -type AbsName = String -- ^ Name of abstract syntax -type ConcName = String -- ^ Name of concrete syntax - --- | Reads file in Portable Grammar Format and produces --- 'PGF' structure. The file is usually produced with: --- --- > $ gf -make readPGF :: FilePath -> IO PGF readPGF fpath = - do pool <- gu_new_pool - pgf <- withCString fpath $ \c_fpath -> - withGuPool $ \tmpPl -> do - exn <- gu_new_exn tmpPl - pgf <- pgf_read c_fpath pool 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 - gu_pool_free pool - ioError (errnoToIOError "readPGF" (Errno errno) Nothing (Just fpath)) - else do gu_pool_free pool - throwIO (PGFError "The grammar cannot be loaded") - else return pgf - pgfFPtr <- newForeignPtr gu_pool_finalizer pool - let touch = touchForeignPtr pgfFPtr - ref <- newIORef Map.empty - allocaBytes (#size GuMapItor) $ \itor -> - do fptr <- wrapMapItorCallback (getLanguages ref touch) - (#poke GuMapItor, fn) itor fptr - pgf_iter_languages pgf itor nullPtr - freeHaskellFunPtr fptr - langs <- readIORef ref - return (PGF pgf langs touch) - where - getLanguages :: IORef (Map.Map String Concr) -> Touch -> MapItorCallback - getLanguages ref touch itor key value exn = do - langs <- readIORef ref - name <- peekUtf8CString (castPtr key) - concr <- fmap (\ptr -> Concr ptr touch) $ peek (castPtr value) - writeIORef ref $! Map.insert name concr langs - -showPGF :: PGF -> String -showPGF p = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - exn <- gu_new_exn tmpPl - withArrayLen ((map concr . Map.elems . languages) p) $ \n_concrs concrs -> - pgf_print (pgf p) (fromIntegral n_concrs) concrs out exn - touchPGF p - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s - --- | List of all languages available in the grammar. -languages :: PGF -> Map.Map ConcName Concr -languages p = langs p - -concreteName :: Concr -> ConcName -concreteName c = unsafePerformIO (peekUtf8CString =<< pgf_concrete_name (concr c)) - -languageCode :: Concr -> Maybe String -languageCode c = unsafePerformIO $ do - c_code <- pgf_language_code (concr c) - if c_code == nullPtr - then return Nothing - else fmap Just (peekUtf8CString c_code) - --- | Generates an exhaustive possibly infinite list of --- all abstract syntax expressions of the given type. --- The expressions are ordered by their probability. -generateAll :: PGF -> Type -> [(Expr,Float)] -generateAll p (Type ctype _) = - unsafePerformIO $ - do genPl <- gu_new_pool - exprPl <- gu_new_pool - exn <- gu_new_exn genPl - enum <- pgf_generate_all (pgf p) ctype exn genPl exprPl - genFPl <- newForeignPtr gu_pool_finalizer genPl - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - fromPgfExprEnum enum genFPl (touchPGF p >> touchForeignPtr exprFPl) - -generateAllFrom :: PGF -> Expr -> [(Expr,Float)] -generateAllFrom = error "generateAllFrom is not implemented yet" - -generateRandom :: RandomGen gen => gen -> PGF -> Type -> [a] -generateRandom = error "generateRandom is not implemented yet" - -generateRandomFrom :: RandomGen gen => gen -> PGF -> Expr -> [a] -generateRandomFrom = error "generateRandomFrom is not implemented yet" - --- | The abstract language name is the name of the top-level --- abstract module -abstractName :: PGF -> AbsName -abstractName p = unsafePerformIO (peekUtf8CString =<< pgf_abstract_name (pgf p)) - --- | The start category is defined in the grammar with --- the \'startcat\' flag. This is usually the sentence category --- but it is not necessary. Despite that there is a start category --- defined you can parse with any category. The start category --- definition is just for convenience. -startCat :: PGF -> Type -startCat p = unsafePerformIO $ do - typPl <- gu_new_pool - c_type <- pgf_start_cat (pgf p) typPl - typeFPl <- newForeignPtr gu_pool_finalizer typPl - return (Type c_type (touchForeignPtr typeFPl)) - -loadConcr :: Concr -> FilePath -> IO () -loadConcr c fpath = withCString fpath $ \c_fpath -> - withCString "rb" $ \c_mode -> - withGuPool $ \tmpPl -> do - file <- fopen c_fpath c_mode - inp <- gu_file_in file tmpPl - exn <- gu_new_exn tmpPl - pgf_concrete_load (concr c) inp 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 "loadConcr" (Errno errno) Nothing (Just fpath)) - else do throwIO (PGFError "The language cannot be loaded") - else return () - -unloadConcr :: Concr -> IO () -unloadConcr c = pgf_concrete_unload (concr c) - --- | The type of a function -functionType :: PGF -> Fun -> Maybe Type -functionType p fn = - unsafePerformIO $ - withGuPool $ \tmpPl -> do - c_fn <- newUtf8CString fn tmpPl - c_type <- pgf_function_type (pgf p) c_fn - return (if c_type == nullPtr - then Nothing - else Just (Type c_type (touchPGF p))) - --- | The type of a function -functionIsDataCon :: PGF -> Fun -> Bool -functionIsDataCon p fn = - unsafePerformIO $ - withGuPool $ \tmpPl -> do - c_fn <- newUtf8CString fn tmpPl - res <- pgf_function_is_constructor (pgf p) c_fn - touchPGF p - return (res /= 0) - --- | Checks an expression against a specified type. -checkExpr :: PGF -> Expr -> Type -> Either String Expr -checkExpr p (Expr c_expr touch1) (Type c_ty touch2) = - unsafePerformIO $ - alloca $ \pexpr -> - withGuPool $ \tmpPl -> do - exn <- gu_new_exn tmpPl - exprPl <- gu_new_pool - poke pexpr c_expr - pgf_check_expr (pgf p) pexpr c_ty exn exprPl - touchPGF p >> touch1 >> touch2 - status <- gu_exn_is_raised exn - if not status - then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl - c_expr <- peek pexpr - return (Right (Expr c_expr (touchForeignPtr exprFPl))) - else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError - c_msg <- (#peek GuExn, data.data) exn - msg <- peekUtf8CString c_msg - gu_pool_free exprPl - if is_tyerr - then return (Left msg) - else throwIO (PGFError msg) - --- | Tries to infer the type of an expression. Note that --- even if the expression is type correct it is not always --- possible to infer its type in the GF type system. --- In this case the function returns an error. -inferExpr :: PGF -> Expr -> Either String (Expr, Type) -inferExpr p (Expr c_expr touch1) = - unsafePerformIO $ - alloca $ \pexpr -> - withGuPool $ \tmpPl -> do - exn <- gu_new_exn tmpPl - exprPl <- gu_new_pool - poke pexpr c_expr - c_ty <- pgf_infer_expr (pgf p) pexpr exn exprPl - touchPGF p >> touch1 - status <- gu_exn_is_raised exn - if not status - then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl - let touch = touchForeignPtr exprFPl - c_expr <- peek pexpr - return (Right (Expr c_expr touch, Type c_ty touch)) - else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError - c_msg <- (#peek GuExn, data.data) exn - msg <- peekUtf8CString c_msg - gu_pool_free exprPl - if is_tyerr - then return (Left msg) - else throwIO (PGFError msg) - --- | Check whether a type is consistent with the abstract --- syntax of the grammar. -checkType :: PGF -> Type -> Either String Type -checkType p (Type c_ty touch1) = - unsafePerformIO $ - alloca $ \pty -> - withGuPool $ \tmpPl -> do - exn <- gu_new_exn tmpPl - typePl <- gu_new_pool - poke pty c_ty - pgf_check_type (pgf p) pty exn typePl - touchPGF p >> touch1 - status <- gu_exn_is_raised exn - if not status - then do typeFPl <- newForeignPtr gu_pool_finalizer typePl - c_ty <- peek pty - return (Right (Type c_ty (touchForeignPtr typeFPl))) - else do is_tyerr <- gu_exn_caught exn gu_exn_type_PgfTypeError - c_msg <- (#peek GuExn, data.data) exn - msg <- peekUtf8CString c_msg - gu_pool_free typePl - if is_tyerr - then return (Left msg) - else throwIO (PGFError msg) - -compute :: PGF -> Expr -> Expr -compute p (Expr c_expr touch1) = - unsafePerformIO $ - withGuPool $ \tmpPl -> do - exn <- gu_new_exn tmpPl - exprPl <- gu_new_pool - c_expr <- pgf_compute (pgf p) c_expr exn tmpPl exprPl - touchPGF p >> touch1 - status <- gu_exn_is_raised exn - if not status - then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr (touchForeignPtr exprFPl)) - else do c_msg <- (#peek GuExn, data.data) exn - msg <- peekUtf8CString c_msg - gu_pool_free exprPl - throwIO (PGFError msg) - -treeProbability :: PGF -> Expr -> Float -treeProbability p (Expr c_expr touch1) = - unsafePerformIO $ do - res <- pgf_compute_tree_probability (pgf p) c_expr - touchPGF p >> touch1 - return (realToFrac res) - -exprHash :: Int32 -> Expr -> Int32 -exprHash h (Expr c_expr touch1) = - unsafePerformIO $ do - h <- pgf_expr_hash (fromIntegral h) c_expr - touch1 - return (fromIntegral h) - -exprSize :: Expr -> Int -exprSize (Expr c_expr touch1) = - unsafePerformIO $ do - size <- pgf_expr_size c_expr - touch1 - return (fromIntegral size) - -exprFunctions :: Expr -> [Fun] -exprFunctions (Expr c_expr touch) = - unsafePerformIO $ - withGuPool $ \tmpPl -> do - seq <- pgf_expr_functions c_expr tmpPl - len <- (#peek GuSeq, len) seq - arr <- peekArray (fromIntegral (len :: CInt)) (seq `plusPtr` (#offset GuSeq, data)) - funs <- mapM peekUtf8CString arr - touch - return funs - -exprSubstitute :: Expr -> [Expr] -> Expr -exprSubstitute (Expr c_expr touch) meta_values = - unsafePerformIO $ - withGuPool $ \tmpPl -> do - c_meta_values <- newSequence (#size PgfExpr) pokeExpr meta_values tmpPl - exprPl <- gu_new_pool - c_expr <- pgf_expr_substitute c_expr c_meta_values exprPl - touch - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - let touch' = sequence_ (touchForeignPtr exprFPl : map touchExpr meta_values) - return (Expr c_expr touch') - where - pokeExpr ptr (Expr c_expr _) = poke ptr c_expr - ------------------------------------------------------------------------------ --- Graphviz - -data GraphvizOptions = GraphvizOptions {noLeaves :: Bool, - noFun :: Bool, - noCat :: Bool, - noDep :: Bool, - nodeFont :: String, - leafFont :: String, - nodeColor :: String, - leafColor :: String, - nodeEdgeStyle :: String, - leafEdgeStyle :: String - } - -graphvizDefaults = GraphvizOptions False False False True "" "" "" "" "" "" - --- | Renders an abstract syntax tree in a Graphviz format. -graphvizAbstractTree :: PGF -> GraphvizOptions -> Expr -> String -graphvizAbstractTree p opts e = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - exn <- gu_new_exn tmpPl - c_opts <- newGraphvizOptions tmpPl opts - pgf_graphviz_abstract_tree (pgf p) (expr e) c_opts out exn - touchExpr e - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s - - -graphvizParseTree :: Concr -> GraphvizOptions -> Expr -> String -graphvizParseTree c opts e = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - exn <- gu_new_exn tmpPl - 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 - -graphvizWordAlignment :: [Concr] -> GraphvizOptions -> Expr -> String -graphvizWordAlignment cs opts e = - unsafePerformIO $ - withGuPool $ \tmpPl -> - withArrayLen (map concr cs) $ \n_concrs ptr -> - do (sb,out) <- newOut tmpPl - exn <- gu_new_exn tmpPl - c_opts <- newGraphvizOptions tmpPl opts - pgf_graphviz_word_alignment ptr (fromIntegral n_concrs) (expr e) c_opts out exn - touchExpr e - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s - - -type Labels = Map.Map Fun [String] - -getDepLabels :: String -> Labels -getDepLabels s = Map.fromList [(f,ls) | f:ls <- map words (lines s)] - --- | Visualize word dependency tree. -graphvizDependencyTree - :: String -- ^ Output format: @"latex"@, @"conll"@, @"malt_tab"@, @"malt_input"@ or @"dot"@ - -> Bool -- ^ Include extra information (debug) - -> Maybe Labels -- ^ abstract label information obtained with 'getDepLabels' - -> Maybe CncLabels -- ^ concrete label information obtained with ' ' (was: unused (was: @Maybe String@)) - -> Concr - -> Expr - -> String -- ^ Rendered output in the specified format -graphvizDependencyTree format debug mlab mclab concr t = - case format of - "latex" -> render . ppLaTeX $ conll2latex' conll - "svg" -> render . ppSVG . toSVG $ conll2latex' conll - "conll" -> printCoNLL conll - "malt_tab" -> render $ vcat (map (hcat . intersperse (char '\t') . (\ws -> [ws !! 0,ws !! 1,ws !! 3,ws !! 6,ws !! 7])) wnodes) - "malt_input" -> render $ vcat (map (hcat . intersperse (char '\t') . take 6) wnodes) - _ -> render $ text "digraph {" $$ - space $$ - nest 2 (text "rankdir=LR ;" $$ - text "node [shape = plaintext] ;" $$ - vcat nodes $$ - vcat links) $$ - text "}" - where - conll = maybe conll0 (\ls -> fixCoNLL ls conll0) mclab - conll0 = (map.map) render wnodes - nodes = map mkNode leaves - links = map mkLink [(fid, fromMaybe (dep_lbl,nil) (lookup fid deps)) | ((cat,fid,fun),_,w) <- tail leaves] - --- CoNLL format: ID FORM LEMMA PLEMMA POS PPOS FEAT PFEAT HEAD PHEAD DEPREL PDEPREL --- P variants are automatically predicted rather than gold standard - - wnodes = [[int i, maltws ws, text fun, text (posCat cat), text cat, unspec, int parent, text lab, unspec, unspec] | - ((cat,fid,fun),i,ws) <- tail leaves, - let (lab,parent) = fromMaybe (dep_lbl,0) - (do (lbl,fid) <- lookup fid deps - (_,i,_) <- find (\((_,fid1,_),i,_) -> fid == fid1) leaves - return (lbl,i)) - ] - maltws = text . concat . intersperse "+" . words -- no spaces in column 2 - - nil = -1 - - bss = bracketedLinearize concr t - - root = ("_",nil,"_") - - leaves = (root,0,root_lbl) : (groupAndIndexIt 1 . concatMap (getLeaves root)) bss - deps = let (_,(h,deps)) = getDeps 0 [] t - in (h,(dep_lbl,nil)):deps - - groupAndIndexIt id [] = [] - groupAndIndexIt id ((p,w):pws) = (p,id,w) : groupAndIndexIt (id+1) pws ---- groupAndIndexIt id ((p,w):pws) = let (ws,pws1) = collect pws ---- in (p,id,unwords (w:ws)) : groupAndIndexIt (id+1) pws1 - where - collect pws@((p1,w):pws1) - | p == p1 = let (ws,pws2) = collect pws1 - in (w:ws,pws2) - collect pws = ([],pws) - - getLeaves parent bs = - case bs of - Leaf w -> [(parent,w)] - Bracket cat fid _ fun bss -> concatMap (getLeaves (cat,fid,fun)) bss - - mkNode ((_,p,_),i,w) = - tag p <+> brackets (text "label = " <> doubleQuotes (int i <> char '.' <+> text w)) <+> semi - - mkLink (x,(lbl,y)) = tag y <+> text "->" <+> tag x <+> text "[label = " <> doubleQuotes (text lbl) <> text "] ;" - - labels = maybe Map.empty id mlab - clabels = maybe [] id mclab - - posCat cat = case Map.lookup cat labels of - Just [p] -> p - _ -> cat - - getDeps n_fid xs e = - case unAbs e of - Just (_, x, e) -> getDeps n_fid (x:xs) e - Nothing -> case unApp e of - Just (f,es) -> let (n_fid_1,ds) = descend n_fid xs es - (mb_h, deps) = selectHead f ds - in case mb_h of - Just (fid,deps0) -> (n_fid_1+1,(fid,deps0++ - [(n_fid_1,(dep_lbl,fid))]++ - concat [(m,(lbl,fid)):ds | (lbl,(m,ds)) <- deps])) - Nothing -> (n_fid_1+1,(n_fid_1,concat [(m,(lbl,n_fid_1)):ds | (lbl,(m,ds)) <- deps])) - Nothing -> (n_fid+1,(n_fid,[])) - - descend n_fid xs es = mapAccumL (\n_fid e -> getDeps n_fid xs e) n_fid es - - selectHead f ds = - case Map.lookup f labels of - Just lbls -> extractHead (zip lbls ds) - Nothing -> extractLast ds - where - extractHead [] = (Nothing, []) - extractHead (ld@(l,d):lds) - | l == head_lbl = (Just d,lds) - | otherwise = let (mb_h,deps) = extractHead lds - in (mb_h,ld:deps) - - extractLast [] = (Nothing, []) - extractLast (d:ds) - | null ds = (Just d,[]) - | otherwise = let (mb_h,deps) = extractLast ds - in (mb_h,(dep_lbl,d):deps) - - dep_lbl = "dep" - head_lbl = "head" - root_lbl = "ROOT" - unspec = text "_" - - ----------------------- should be a separate module? - --- visualization with latex output. AR Nov 2015 - -conlls2latexDoc :: [String] -> String -conlls2latexDoc = - render . - latexDoc . - vcat . - intersperse (text "" $+$ app "vspace" (text "4mm")) . - map conll2latex . - filter (not . null) - -conll2latex :: String -> Doc -conll2latex = ppLaTeX . conll2latex' . parseCoNLL - -conll2latex' :: CoNLL -> [LaTeX] -conll2latex' = dep2latex . conll2dep' - -data Dep = Dep { - wordLength :: Int -> Double -- length of word at position int -- was: fixed width, millimetres (>= 20.0) - , tokens :: [(String,String)] -- word, pos (0..) - , deps :: [((Int,Int),String)] -- from, to, label - , root :: Int -- root word position - } - --- some general measures -defaultWordLength = 20.0 -- the default fixed width word length, making word 100 units -defaultUnit = 0.2 -- unit in latex pictures, 0.2 millimetres -spaceLength = 10.0 -charWidth = 1.8 - -wsize rwld w = 100 * rwld w + spaceLength -- word length, units -wpos rwld i = sum [wsize rwld j | j <- [0..i-1]] -- start position of the i'th word -wdist rwld x y = sum [wsize rwld i | i <- [min x y .. max x y - 1]] -- distance between words x and y -labelheight h = h + arcbase + 3 -- label just above arc; 25 would put it just below -labelstart c = c - 15.0 -- label starts 15u left of arc centre -arcbase = 30.0 -- arcs start and end 40u above the bottom -arcfactor r = r * 600 -- reduction of arc size from word distance -xyratio = 3 -- width/height ratio of arcs - -putArc :: (Int -> Double) -> Int -> Int -> Int -> String -> [DrawingCommand] -putArc frwld height x y label = [oval,arrowhead,labelling] where - oval = Put (ctr,arcbase) (OvalTop (wdth,hght)) - arrowhead = Put (endp,arcbase + 5) (ArrowDown 5) -- downgoing arrow 5u above the arc base - labelling = Put (labelstart ctr,labelheight (hght/2)) (TinyText label) - dxy = wdist frwld x y -- distance between words, >>= 20.0 - ndxy = 100 * rwld * fromIntegral height -- distance that is indep of word length - hdxy = dxy / 2 -- half the distance - wdth = dxy - (arcfactor rwld)/dxy -- longer arcs are wider in proportion - hght = ndxy / (xyratio * rwld) -- arc height is independent of word length - begp = min x y -- begin position of oval - ctr = wpos frwld begp + hdxy + (if x < y then 20 else 10) -- LR arcs are farther right from center of oval - endp = (if x < y then (+) else (-)) ctr (wdth/2) -- the point of the arrow - rwld = 0.5 ---- - -dep2latex :: Dep -> [LaTeX] -dep2latex d = - [Comment (unwords (map fst (tokens d))), - Picture defaultUnit (width,height) ( - [Put (wpos rwld i,0) (Text w) | (i,w) <- zip [0..] (map fst (tokens d))] -- words - ++ [Put (wpos rwld i,15) (TinyText w) | (i,w) <- zip [0..] (map snd (tokens d))] -- pos tags 15u above bottom - ++ concat [putArc rwld (aheight x y) x y label | ((x,y),label) <- deps d] -- arcs and labels - ++ [Put (wpos rwld (root d) + 15,height) (ArrowDown (height-arcbase))] - ++ [Put (wpos rwld (root d) + 20,height - 10) (TinyText "ROOT")] - )] - where - wld i = wordLength d i -- >= 20.0 - rwld i = (wld i) / defaultWordLength -- >= 1.0 - aheight x y = depth (min x y) (max x y) + 1 ---- abs (x-y) - arcs = [(min u v, max u v) | ((u,v),_) <- deps d] - depth x y = case [(u,v) | (u,v) <- arcs, (x < u && v <= y) || (x == u && v < y)] of ---- only projective arcs counted - [] -> 0 - uvs -> 1 + maximum (0:[depth u v | (u,v) <- uvs]) - width = {-round-} (sum [wsize rwld w | (w,_) <- zip [0..] (tokens d)]) + {-round-} spaceLength * fromIntegral ((length (tokens d)) - 1) - height = 50 + 20 * {-round-} (maximum (0:[aheight x y | ((x,y),_) <- deps d])) - -type CoNLL = [[String]] -parseCoNLL :: String -> CoNLL -parseCoNLL = map words . lines - ---conll2dep :: String -> Dep ---conll2dep = conll2dep' . parseCoNLL - -conll2dep' :: CoNLL -> Dep -conll2dep' ls = Dep { - wordLength = wld - , tokens = toks - , deps = dps - , root = head $ [read x-1 | x:_:_:_:_:_:"0":_ <- ls] ++ [1] - } - where - wld i = maximum (0:[charWidth * fromIntegral (length w) | w <- let (tok,pos) = toks !! i in [tok,pos]]) - toks = [(w,c) | _:w:_:c:_ <- ls] - dps = [((read y-1, read x-1),lab) | x:_:_:_:_:_:y:lab:_ <- ls, y /="0"] - --maxdist = maximum [abs (x-y) | ((x,y),_) <- dps] - - --- * LaTeX Pictures (see https://en.wikibooks.org/wiki/LaTeX/Picture) - --- We render both LaTeX and SVG from this intermediate representation of --- LaTeX pictures. - -data LaTeX = Comment String | Picture UnitLengthMM Size [DrawingCommand] -data DrawingCommand = Put Position Object -data Object = Text String | TinyText String | OvalTop Size | ArrowDown Length - -type UnitLengthMM = Double -type Size = (Double,Double) -type Position = (Double,Double) -type Length = Double - - --- * latex formatting -ppLaTeX = vcat . map ppLaTeX1 - where - ppLaTeX1 el = - case el of - Comment s -> comment s - Picture unit size cmds -> - app "setlength{\\unitlength}" (text (show unit ++ "mm")) - $$ hang (app "begin" (text "picture")<>text (show size)) 2 - (vcat (map ppDrawingCommand cmds)) - $$ app "end" (text "picture") - $$ text "" - - ppDrawingCommand (Put pos obj) = put pos (ppObject obj) - - ppObject obj = - case obj of - Text s -> text s - TinyText s -> small (text s) - OvalTop size -> text "\\oval" <> text (show size) <> text "[t]" - ArrowDown len -> app "vector(0,-1)" (text (show len)) - - put p@(_,_) = app ("put" ++ show p) - small w = text "{\\tiny" <+> w <> text "}" - comment s = text "%%" <+> text s -- line break show follow - -app macro arg = text "\\" <> text macro <> text "{" <> arg <> text "}" - - -latexDoc :: Doc -> Doc -latexDoc body = - vcat [text "\\documentclass{article}", - text "\\usepackage[utf8]{inputenc}", - text "\\begin{document}", - body, - text "\\end{document}"] - --- * SVG (see https://www.w3.org/Graphics/SVG/IG/resources/svgprimer.html) - --- | Render LaTeX pictures as SVG -toSVG = concatMap toSVG1 - where - toSVG1 el = - case el of - Comment s -> [] - Picture unit size@(w,h) cmds -> - [Elem "svg" ["width".=x1,"height".=y0+5, - ("viewBox",unwords (map show [0,0,x1,y0+5])), - ("version","1.1"), - ("xmlns","http://www.w3.org/2000/svg")] - (white_bg:concatMap draw cmds)] - where - white_bg = - Elem "rect" ["x".=0,"y".=0,"width".=x1,"height".=y0+5, - ("fill","white")] [] - - draw (Put pos obj) = objectSVG pos obj - - objectSVG pos obj = - case obj of - Text s -> [text 16 pos s] - TinyText s -> [text 10 pos s] - OvalTop size -> [ovalTop pos size] - ArrowDown len -> arrowDown pos len - - text h (x,y) s = - Elem "text" ["x".=xc x,"y".=yc y-2,"font-size".=h] - [CharData s] - - ovalTop (x,y) (w,h) = - Elem "path" [("d",path),("stroke","black"),("fill","none")] [] - where - x1 = x-w/2 - x2 = min x (x1+r) - x3 = max x (x4-r) - x4 = x+w/2 - y1 = y - y2 = y+r - r = h/2 - sx = show . xc - sy = show . yc - path = unwords (["M",sx x1,sy y1,"Q",sx x1,sy y2,sx x2,sy y2, - "L",sx x3,sy y2,"Q",sx x4,sy y2,sx x4,sy y1]) - - arrowDown (x,y) len = - [Elem "line" ["x1".=xc x,"y1".=yc y,"x2".=xc x,"y2".=y2, - ("stroke","black")] [], - Elem "path" [("d",unwords arrowhead)] []] - where - x2 = xc x - y2 = yc (y-len) - arrowhead = "M":map show [x2,y2,x2-3,y2-6,x2+3,y2-6] - - xc x = num x+5 - yc y = y0-num y - x1 = num w+10 - y0 = num h+20 - num x = round (scale*x) - scale = unit*5 - - infix 0 .= - n.=v = (n,show v) - --- * SVG is XML - -data SVG = CharData String | Elem TagName Attrs [SVG] -type TagName = String -type Attrs = [(String,String)] - -ppSVG svg = - vcat [text "", - text "", - text "", - vcat (map ppSVG1 svg)] -- It should be a single element... - where - ppSVG1 svg1 = - case svg1 of - CharData s -> text (encode s) - Elem tag attrs [] -> - text "<"<>text tag<>cat (map attr attrs) <> text "/>" - Elem tag attrs svg -> - cat [text "<"<>text tag<>cat (map attr attrs) <> text ">", - nest 2 (cat (map ppSVG1 svg)), - text "text tag<>text ">"] - - attr (n,v) = text " "<>text n<>text "=\""<>text (encode v)<>text "\"" - - encode s = foldr encodeEntity "" s - - encodeEntity = encodeEntity' (const False) - encodeEntity' esc c r = - case c of - '&' -> "&"++r - '<' -> "<"++r - '>' -> ">"++r - _ -> c:r - - ----------------------------------- --- concrete syntax annotations (local) on top of conll --- examples of annotations: --- UseComp {"not"} PART neg head --- UseComp {*} AUX cop head - -type CncLabels = [(String, String -> Maybe (String -> String,String,String))] --- (fun, word -> (pos,label,target)) --- the pos can remain unchanged, as in the current notation in the article - -fixCoNLL :: CncLabels -> CoNLL -> CoNLL -fixCoNLL labels conll = map fixc conll where - fixc row = case row of - (i:word:fun:pos:cat:x_:"0":"dep":xs) -> (i:word:fun:pos:cat:x_:"0":"root":xs) --- change the root label from dep to root - (i:word:fun:pos:cat:x_:j:label:xs) -> case look (fun,word) of - Just (pos',label',"head") -> (i:word:fun:pos' pos:cat:x_:j :label':xs) - Just (pos',label',target) -> (i:word:fun:pos' pos:cat:x_: getDep j target:label':xs) - _ -> row - _ -> row - - look (fun,word) = case lookup fun labels of - Just relabel -> case relabel word of - Just row -> Just row - _ -> case lookup "*" labels of - Just starlabel -> starlabel word - _ -> Nothing - _ -> case lookup "*" labels of - Just starlabel -> starlabel word - _ -> Nothing - - getDep j label = maybe j id $ lookup (label,j) [((label,j),i) | i:word:fun:pos:cat:x_:j:label:xs <- conll] - -getCncDepLabels :: String -> CncLabels -getCncDepLabels = map merge . groupBy (\ (x,_) (a,_) -> x == a) . concatMap analyse . filter choose . lines where - --- choose is for compatibility with the general notation - choose line = notElem '(' line && elem '{' line --- ignoring non-local (with "(") and abstract (without "{") rules - - analyse line = case break (=='{') line of - (beg,_:ws) -> case break (=='}') ws of - (toks,_:target) -> case (words beg, words target) of - (fun:_,[ label,j]) -> [(fun, (tok, (id, label,j))) | tok <- getToks toks] - (fun:_,[pos,label,j]) -> [(fun, (tok, (const pos,label,j))) | tok <- getToks toks] - _ -> [] - _ -> [] - _ -> [] - merge rules@((fun,_):_) = (fun, \tok -> - case lookup tok (map snd rules) of - Just new -> return new - _ -> lookup "*" (map snd rules) - ) - getToks = words . map (\c -> if elem c "\"," then ' ' else c) - -printCoNLL :: CoNLL -> String -printCoNLL = unlines . map (concat . intersperse "\t") - - -newGraphvizOptions :: Ptr GuPool -> GraphvizOptions -> IO (Ptr PgfGraphvizOptions) -newGraphvizOptions pool opts = do - c_opts <- gu_malloc pool (#size PgfGraphvizOptions) - (#poke PgfGraphvizOptions, noLeaves) c_opts (if noLeaves opts then 1 else 0 :: CInt) - (#poke PgfGraphvizOptions, noFun) c_opts (if noFun opts then 1 else 0 :: CInt) - (#poke PgfGraphvizOptions, noCat) c_opts (if noCat opts then 1 else 0 :: CInt) - (#poke PgfGraphvizOptions, noDep) c_opts (if noDep opts then 1 else 0 :: CInt) - newUtf8CString (nodeFont opts) pool >>= (#poke PgfGraphvizOptions, nodeFont) c_opts - newUtf8CString (leafFont opts) pool >>= (#poke PgfGraphvizOptions, leafFont) c_opts - newUtf8CString (nodeColor opts) pool >>= (#poke PgfGraphvizOptions, nodeColor) c_opts - newUtf8CString (leafColor opts) pool >>= (#poke PgfGraphvizOptions, leafColor) c_opts - newUtf8CString (nodeEdgeStyle opts) pool >>= (#poke PgfGraphvizOptions, nodeEdgeStyle) c_opts - newUtf8CString (leafEdgeStyle opts) pool >>= (#poke PgfGraphvizOptions, leafEdgeStyle) c_opts - return c_opts - ------------------------------------------------------------------------------ --- Functions using Concr --- Morpho analyses, parsing & linearization - --- | 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 --- a multiword expression (i.e. this is the lemma). --- 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 --- conditionalized on the category of the function. This makes it --- possible to compare the likelihood of two functions even if they --- have different types. -type MorphoAnalysis = (Fun,String,Float) - --- | '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] -lookupMorpho (Concr concr master) sent = - unsafePerformIO $ - withGuPool $ \tmpPl -> do - ref <- newIORef [] - cback <- gu_malloc tmpPl (#size PgfMorphoCallback) - fptr <- wrapLookupMorphoCallback (getAnalysis ref) - (#poke PgfMorphoCallback, callback) cback fptr - c_sent <- newUtf8CString sent tmpPl - pgf_lookup_morpho concr c_sent cback nullPtr - freeHaskellFunPtr fptr - readIORef ref - --- | 'lookupCohorts' takes an arbitrary string an produces --- a list of all places where lexical items from the grammar have been --- identified (i.e. cohorts). The list consists of triples of the format @(start,ans,end)@, --- where @start-end@ identifies the span in the text and @ans@ is --- the list of possible morphological analyses similar to 'lookupMorpho'. --- --- 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,String,[MorphoAnalysis],Int)] -lookupCohorts lang@(Concr concr master) sent = - unsafePerformIO $ - do pl <- gu_new_pool - ref <- newIORef [] - cback <- gu_malloc pl (#size PgfMorphoCallback) - fptr <- wrapLookupMorphoCallback (getAnalysis ref) - (#poke PgfMorphoCallback, callback) cback fptr - 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 0 sent ref - where - fromCohortRange enum fpl fptr i sent ref = - allocaBytes (#size PgfCohortRange) $ \ptr -> - withForeignPtr fpl $ \pl -> - do gu_enum_next enum ptr pl - buf <- (#peek PgfCohortRange, buf) ptr - if buf == nullPtr - then do finalizeForeignPtr fpl - freeHaskellFunPtr fptr - touchConcr lang - return [] - else do start <- (#peek PgfCohortRange, start.pos) ptr - end <- (#peek PgfCohortRange, end.pos) ptr - ans <- readIORef ref - writeIORef ref [] - 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 = - unsafePerformIO $ - do pl <- gu_new_pool - enum <- pgf_fullform_lexicon (concr lang) pl - fpl <- newForeignPtr gu_pool_finalizer pl - fromFullFormEntry enum fpl - where - fromFullFormEntry :: Ptr GuEnum -> ForeignPtr GuPool -> IO [(String, [MorphoAnalysis])] - fromFullFormEntry enum fpl = - do ffEntry <- alloca $ \ptr -> - withForeignPtr fpl $ \pl -> - do gu_enum_next enum ptr pl - peek ptr - if ffEntry == nullPtr - then do finalizeForeignPtr fpl - touchConcr lang - return [] - else do tok <- peekUtf8CString =<< pgf_fullform_get_string ffEntry - ref <- newIORef [] - allocaBytes (#size PgfMorphoCallback) $ \cback -> - do fptr <- wrapLookupMorphoCallback (getAnalysis ref) - (#poke PgfMorphoCallback, callback) cback fptr - pgf_fullform_get_analyses ffEntry cback nullPtr - ans <- readIORef ref - toks <- unsafeInterleaveIO (fromFullFormEntry enum fpl) - return ((tok,ans) : toks) - -getAnalysis :: IORef [MorphoAnalysis] -> LookupMorphoCallback -getAnalysis ref self c_lemma c_anal prob exn = do - ans <- readIORef ref - lemma <- peekUtf8CString c_lemma - anal <- peekUtf8CString c_anal - writeIORef ref ((lemma, anal, prob):ans) - --- | This data type encodes the different outcomes which you could get from the parser. -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 - -- we get the abstract syntax trees as either a list or a chart. - | ParseIncomplete -- ^ The sentence is not complete. - -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 - -- 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) - -> ParseOutput [(Expr,Float)] -parseWithHeuristics lang (Type ctype touchType) sent heuristic callbacks = - unsafePerformIO $ - do exprPl <- gu_new_pool - parsePl <- gu_new_pool - exn <- gu_new_exn parsePl - sent <- newUtf8CString sent parsePl - callbacks_map <- mkCallbacksMap (concr lang) callbacks parsePl - enum <- pgf_parse_with_heuristics (concr lang) ctype sent heuristic callbacks_map exn parsePl exprPl - failed <- gu_exn_is_raised exn - if failed - then do is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError - 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 - gu_pool_free parsePl - gu_pool_free exprPl - return (ParseFailed (fromIntegral (c_offset :: CInt)) tok) - else do gu_pool_free parsePl - gu_pool_free exprPl - 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 - gu_pool_free parsePl - gu_pool_free exprPl - throwIO (PGFError msg) - else do gu_pool_free parsePl - gu_pool_free exprPl - throwIO (PGFError "Parsing failed") - else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl) - return (ParseOk exprs) - -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 - ccat <- newUtf8CString cat pool - match <- wrapLiteralMatchCallback (match_callback match) - predict <- wrapLiteralPredictCallback predict_callback - hspgf_callbacks_map_add_literal concr callbacks_map ccat match predict pool - return callbacks_map - where - match_callback match c_ann poffset out_pool = do - coffset <- peek poffset - 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 <- pgf_clone_expr (expr e) out_pool - - ep <- gu_malloc out_pool (#size PgfExprProb) - (#poke PgfExprProb, expr) ep c_e - (#poke PgfExprProb, prob) ep prob - return ep - - predict_callback _ _ _ = return nullPtr - -lookupSentence :: Concr -- ^ the language with which we parse - -> Type -- ^ the start category - -> String -- ^ the input sentence - -> [(Expr,Float)] -lookupSentence lang (Type ctype _) sent = - unsafePerformIO $ - do exprPl <- gu_new_pool - parsePl <- gu_new_pool - sent <- newUtf8CString sent parsePl - enum <- pgf_lookup_sentence (concr lang) ctype sent parsePl exprPl - parseFPl <- newForeignPtr gu_pool_finalizer parsePl - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl) - return exprs - - --- | 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 --- prediction or completion is appropriate. The third function --- is the oracle for literals. -type Oracle = (Maybe (Cat -> String -> Int -> Bool) - ,Maybe (Cat -> String -> Int -> Bool) - ,Maybe (Cat -> String -> Int -> Maybe (Expr,Float,Int)) - ) - -parseWithOracle :: Concr -- ^ the language with which we parse - -> Cat -- ^ the start category - -> String -- ^ the input sentence - -> Oracle - -> ParseOutput [(Expr,Float)] -parseWithOracle lang cat sent (predict,complete,literal) = - unsafePerformIO $ - do parsePl <- gu_new_pool - exprPl <- gu_new_pool - exn <- gu_new_exn parsePl - cat <- newUtf8CString cat parsePl - sent <- newUtf8CString sent parsePl - predictPtr <- maybe (return nullFunPtr) (wrapOracleCallback . oracleWrapper) predict - completePtr <- maybe (return nullFunPtr) (wrapOracleCallback . oracleWrapper) complete - literalPtr <- maybe (return nullFunPtr) (wrapOracleLiteralCallback . oracleLiteralWrapper) literal - cback <- hspgf_new_oracle_callback sent predictPtr completePtr literalPtr parsePl - enum <- pgf_parse_with_oracle (concr lang) cat sent cback exn parsePl exprPl - 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 - gu_pool_free parsePl - gu_pool_free exprPl - return (ParseFailed (fromIntegral (c_offset :: CInt)) tok) - else do gu_pool_free parsePl - gu_pool_free exprPl - 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 - gu_pool_free parsePl - gu_pool_free exprPl - throwIO (PGFError msg) - else do gu_pool_free parsePl - gu_pool_free exprPl - throwIO (PGFError "Parsing failed") - else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl) - return (ParseOk exprs) - where - oracleWrapper oracle catPtr lblPtr offset = do - cat <- peekUtf8CString catPtr - lbl <- peekUtf8CString lblPtr - return (oracle cat lbl (fromIntegral offset)) - - oracleLiteralWrapper oracle catPtr lblPtr poffset out_pool = do - cat <- peekUtf8CString catPtr - lbl <- peekUtf8CString lblPtr - offset <- peek poffset - case oracle cat lbl (fromIntegral offset) of - 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 - - ep <- gu_malloc out_pool (#size PgfExprProb) - (#poke PgfExprProb, expr) ep c_e - (#poke PgfExprProb, prob) ep prob - 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 $ - withGuPool $ \pl -> do - res <- newUtf8CString id pl >>= pgf_has_linearization (concr lang) - return (res /= 0) - --- | Linearizes an expression as a string in the language -linearize :: Concr -> Expr -> String -linearize lang e = unsafePerformIO $ - withGuPool $ \pl -> - do (sb,out) <- newOut pl - exn <- gu_new_exn pl - pgf_linearize (concr lang) (expr e) out exn - touchExpr e - failed <- gu_exn_is_raised exn - if failed - then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist - if is_nonexist - then return "" - 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 - throwIO (PGFError msg) - else throwIO (PGFError "The abstract tree cannot be linearized") - else do lin <- gu_string_buf_freeze sb pl - peekUtf8CString lin - --- | Generates all possible linearizations of an expression -linearizeAll :: Concr -> Expr -> [String] -linearizeAll lang e = unsafePerformIO $ - do pl <- gu_new_pool - exn <- gu_new_exn pl - cts <- pgf_lzr_concretize (concr lang) (expr e) exn pl - failed <- gu_exn_is_raised exn - if failed - then throwExn exn pl - else collect cts exn pl - where - collect cts exn pl = withGuPool $ \tmpPl -> do - ctree <- alloca $ \ptr -> do gu_enum_next cts ptr tmpPl - peek ptr - if ctree == nullPtr - then do gu_pool_free pl - touchExpr e - return [] - else do (sb,out) <- newOut tmpPl - ctree <- pgf_lzr_wrap_linref ctree tmpPl - pgf_lzr_linearize_simple (concr lang) ctree 0 out exn tmpPl - 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 cts exn pl - else throwExn exn pl - else do lin <- gu_string_buf_freeze sb tmpPl - s <- peekUtf8CString lin - ss <- collect cts exn pl - return (s:ss) - - throwExn exn pl = 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 pl - throwIO (PGFError msg) - else do gu_pool_free pl - throwIO (PGFError "The abstract tree cannot be linearized") - --- | Generates a table of linearizations for an expression -tabularLinearize :: Concr -> Expr -> [(String, String)] -tabularLinearize lang e = - case tabularLinearizeAll lang e of - (lins:_) -> lins - _ -> [] - --- | Generates a table of linearizations for an expression -tabularLinearizeAll :: Concr -> Expr -> [[(String, String)]] -tabularLinearizeAll lang e = unsafePerformIO $ - withGuPool $ \tmpPl -> do - 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 - where - collect cts exn tmpPl = do - ctree <- alloca $ \ptr -> do gu_enum_next cts ptr tmpPl - peek ptr - if ctree == nullPtr - then do touchExpr e - return [] - else do labels <- alloca $ \p_n_lins -> - alloca $ \p_labels -> do - pgf_lzr_get_table (concr lang) ctree p_n_lins p_labels - n_lins <- peek p_n_lins - labels <- peek p_labels - labels <- peekArray (fromIntegral n_lins) labels - labels <- mapM peekCString labels - return labels - lins <- collectTable lang ctree 0 labels exn tmpPl - linss <- collect cts exn tmpPl - return (lins : linss) - - collectTable lang ctree lin_idx [] exn tmpPl = return [] - collectTable lang ctree lin_idx (label:labels) exn tmpPl = do - (sb,out) <- newOut tmpPl - pgf_lzr_linearize_simple (concr lang) ctree lin_idx out exn tmpPl - failed <- gu_exn_is_raised exn - if failed - then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist - if is_nonexist - then collectTable lang ctree (lin_idx+1) labels exn tmpPl - else throwExn exn - else do lin <- gu_string_buf_freeze sb tmpPl - s <- peekUtf8CString lin - ss <- collectTable lang ctree (lin_idx+1) labels exn tmpPl - return ((label,s):ss) - -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) - - --- | 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 - | 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 - -- 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 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 --- the brackets are shown as @(S ...)@ where --- @S@ is the category. -showBracketedString :: BracketedString -> String -showBracketedString = render . ppBracketedString - -ppBracketedString (Leaf t) = text t -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] -flattenBracketedString (Leaf w) = [w] -flattenBracketedString (Bracket _ _ _ _ bss) = concatMap flattenBracketedString bss - -bracketedLinearize :: Concr -> Expr -> [BracketedString] -bracketedLinearize 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 throwExn exn - else do ctree <- alloca $ \ptr -> do gu_enum_next cts ptr pl - peek ptr - if ctree == nullPtr - then do touchExpr e - return [] - else do ctree <- pgf_lzr_wrap_linref ctree pl - ref <- newIORef ([],[]) - 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 - if is_nonexist - then return [] - 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_ann c_fun = do - (stack,bs) <- readIORef ref - writeIORef ref (bs:stack,[]) - - 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 - ann <- peekUtf8CString c_ann - fun <- peekUtf8CString c_fun - 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") - -alignWords :: Concr -> Expr -> [(String, [Int])] -alignWords lang e = unsafePerformIO $ - withGuPool $ \pl -> - do exn <- gu_new_exn pl - seq <- pgf_align_words (concr lang) (expr e) exn pl - touchConcr lang - touchExpr e - failed <- gu_exn_is_raised exn - if failed - then do is_nonexist <- gu_exn_caught exn gu_exn_type_PgfLinNonExist - if is_nonexist - then return [] - 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 - throwIO (PGFError msg) - else throwIO (PGFError "The abstract tree cannot be linearized") - else do len <- (#peek GuSeq, len) seq - arr <- peekArray (fromIntegral (len :: CInt)) (seq `plusPtr` (#offset GuSeq, data)) - mapM peekAlignmentPhrase arr - where - peekAlignmentPhrase :: Ptr () -> IO (String, [Int]) - peekAlignmentPhrase ptr = do - c_phrase <- (#peek PgfAlignmentPhrase, phrase) ptr - phrase <- peekUtf8CString c_phrase - n_fids <- (#peek PgfAlignmentPhrase, n_fids) ptr - (fids :: [CInt]) <- peekArray (fromIntegral (n_fids :: CInt)) (ptr `plusPtr` (#offset PgfAlignmentPhrase, fids)) - return (phrase, map fromIntegral fids) - -gizaAlignment = error "gizaAlignment is not implemented" - -printName :: Concr -> Fun -> Maybe String -printName lang fun = - unsafePerformIO $ - withGuPool $ \tmpPl -> do - c_fun <- newUtf8CString fun tmpPl - c_name <- pgf_print_name (concr lang) c_fun - name <- if c_name == nullPtr - then return Nothing - else fmap Just (peekUtf8CString c_name) - touchConcr lang - return name - --- | List of all functions defined in the abstract syntax -functions :: PGF -> [Fun] -functions p = - unsafePerformIO $ - withGuPool $ \tmpPl -> - allocaBytes (#size GuMapItor) $ \itor -> do - exn <- gu_new_exn tmpPl - ref <- newIORef [] - fptr <- wrapMapItorCallback (getFunctions ref) - (#poke GuMapItor, fn) itor fptr - pgf_iter_functions (pgf p) itor exn - touchPGF p - freeHaskellFunPtr fptr - fs <- readIORef ref - return (reverse fs) - where - getFunctions :: IORef [String] -> MapItorCallback - getFunctions ref itor key value exn = do - names <- readIORef ref - name <- peekUtf8CString (castPtr key) - writeIORef ref $! (name : names) - --- | List of all functions defined for a category -functionsByCat :: PGF -> Cat -> [Fun] -functionsByCat p cat = - unsafePerformIO $ - withGuPool $ \tmpPl -> - allocaBytes (#size GuMapItor) $ \itor -> do - exn <- gu_new_exn tmpPl - ref <- newIORef [] - fptr <- wrapMapItorCallback (getFunctions ref) - (#poke GuMapItor, fn) itor fptr - ccat <- newUtf8CString cat tmpPl - pgf_iter_functions_by_cat (pgf p) ccat itor exn - touchPGF p - freeHaskellFunPtr fptr - fs <- readIORef ref - return (reverse fs) - where - getFunctions :: IORef [String] -> MapItorCallback - getFunctions ref itor key value exn = do - names <- readIORef ref - name <- peekUtf8CString (castPtr key) - writeIORef ref $! (name : names) - --- | List of all categories defined in the grammar. --- The categories are defined in the abstract syntax --- with the \'cat\' keyword. -categories :: PGF -> [Cat] -categories p = - unsafePerformIO $ - withGuPool $ \tmpPl -> - allocaBytes (#size GuMapItor) $ \itor -> do - exn <- gu_new_exn tmpPl - ref <- newIORef [] - fptr <- wrapMapItorCallback (getCategories ref) - (#poke GuMapItor, fn) itor fptr - pgf_iter_categories (pgf p) itor exn - touchPGF p - freeHaskellFunPtr fptr - cs <- readIORef ref - return (reverse cs) - where - getCategories :: IORef [String] -> MapItorCallback - getCategories ref itor key value exn = do - names <- readIORef ref - name <- peekUtf8CString (castPtr key) - writeIORef ref $! (name : names) - -categoryContext :: PGF -> Cat -> Maybe [Hypo] -categoryContext p cat = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do c_cat <- newUtf8CString cat tmpPl - c_hypos <- pgf_category_context (pgf p) c_cat - if c_hypos == nullPtr - then return Nothing - else do n_hypos <- (#peek GuSeq, len) c_hypos - hypos <- peekHypos (c_hypos `plusPtr` (#offset GuSeq, data)) 0 n_hypos - return (Just hypos) - where - peekHypos :: Ptr a -> Int -> Int -> IO [Hypo] - peekHypos c_hypo i n - | i < n = do cid <- (#peek PgfHypo, cid) c_hypo >>= peekUtf8CString - c_ty <- (#peek PgfHypo, type) c_hypo - bt <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo) - hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n - return ((bt,cid,Type c_ty (touchPGF p)) : hs) - | otherwise = return [] - - toBindType :: CInt -> BindType - toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit - toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit - -categoryProbability :: PGF -> Cat -> Float -categoryProbability p cat = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do c_cat <- newUtf8CString cat tmpPl - c_prob <- pgf_category_prob (pgf p) c_cat - touchPGF p - return (realToFrac c_prob) - ------------------------------------------------------------------------------ --- Helper functions - -fromPgfExprEnum :: Ptr GuEnum -> ForeignPtr GuPool -> Touch -> IO [(Expr, Float)] -fromPgfExprEnum enum fpl touch = - do pgfExprProb <- alloca $ \ptr -> - withForeignPtr fpl $ \pl -> - do gu_enum_next enum ptr pl - peek ptr - if pgfExprProb == nullPtr - then do finalizeForeignPtr fpl - return [] - else do expr <- (#peek PgfExprProb, expr) pgfExprProb - ts <- unsafeInterleaveIO (fromPgfExprEnum enum fpl touch) - prob <- (#peek PgfExprProb, prob) pgfExprProb - return ((Expr expr touch,prob) : ts) - -fromPgfTokenEnum :: Ptr GuEnum -> ForeignPtr GuPool -> IO [(String, Cat, Fun, Float)] -fromPgfTokenEnum enum fpl = - do pgfTokenProb <- alloca $ \ptr -> - withForeignPtr fpl $ \pl -> - do gu_enum_next enum ptr pl - peek ptr - if pgfTokenProb == nullPtr - then do finalizeForeignPtr fpl - return [] - else do tok <- (#peek PgfTokenProb, tok) pgfTokenProb >>= peekUtf8CString - cat <- (#peek PgfTokenProb, cat) pgfTokenProb >>= peekUtf8CString - fun <- (#peek PgfTokenProb, fun) pgfTokenProb >>= peekUtf8CString - prob <- (#peek PgfTokenProb, prob) pgfTokenProb - ts <- unsafeInterleaveIO (fromPgfTokenEnum enum fpl) - return ((tok,cat,fun,prob) : ts) + allocaBytes (#size PgfExn) $ \c_exn -> do + c_pgf <- pgf_read c_fpath c_exn + ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType) + if ex_type == (#const PGF_EXN_NONE) + then do fptr <- newForeignPtr pgf_free_fptr c_pgf + return (PGF fptr Map.empty) + else if ex_type == (#const PGF_EXN_SYSTEM_ERROR) + then do errno <- (#peek PgfExn, code) c_exn + ioError (errnoToIOError "readPGF" (Errno errno) Nothing (Just fpath)) + else do c_msg <- (#peek PgfExn, msg) c_exn + msg <- peekCString c_msg + throwIO (PGFError msg) ----------------------------------------------------------------------- -- Exceptions @@ -1977,83 +51,3 @@ newtype PGFError = PGFError String instance Exception PGFError ------------------------------------------------------------------------ - -type LiteralCallback = - 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 --- (based on ../java/org/grammaticalframework/pgf/NercLiteralCallback.java) -nerc :: LiteralCallback -nerc pgf (lang,concr) sentence lin_idx offset = - case consume capitalized (drop offset sentence) of - (capwords@(_:_),rest) | - not ("Eng" `isSuffixOf` lang && name `elem` ["I","I'm"]) -> - if null ls - then pn - else case cat of - "PN" -> retLit (mkApp lemma []) - "WeekDay" -> retLit (mkApp "weekdayPN" [mkApp lemma []]) - "Month" -> retLit (mkApp "monthPN" [mkApp lemma []]) - _ -> Nothing - where - retLit e = Just (e,0,end_offset) - where end_offset = offset+length name - pn = retLit (mkApp "SymbPN" [mkApp "MkSymb" [mkStr name]]) - ((lemma,cat),_) = maximumBy (compare `on` snd) (reverse ls) - ls = [((fun,cat),p) - |(fun,_,p)<-lookupMorpho concr name, - Just cat <- [functionCat fun], - cat/="Nationality"] - name = trimRight (concat capwords) - _ -> Nothing - where - -- | Variant of unfoldr - consume munch xs = - case munch xs of - Nothing -> ([],xs) - Just (y,xs') -> (y:ys,xs'') - where (ys,xs'') = consume munch xs' - - functionCat f = fmap ((\(_,c,_) -> c) . unType) (functionType pgf f) - --- | Callback to parse arbitrary words as chunks (from --- ../java/org/grammaticalframework/pgf/UnknownLiteralCallback.java) -chunk :: LiteralCallback -chunk _ (_,concr) sentence lin_idx offset = - case uncapitalized (drop offset sentence) of - Just (word0@(_:_),rest) | null (lookupMorpho concr word) -> - Just (expr,0,offset+length word) - where - word = trimRight word0 - expr = mkApp "MkSymb" [mkStr word] - _ -> Nothing - - --- More helper functions - -trimRight = reverse . dropWhile isSpace . reverse - -capitalized = capitalized' isUpper -uncapitalized = capitalized' (not.isUpper) - -capitalized' test s@(c:_) | test c = - case span (not.isSpace) s of - (name,rest1) -> - case span isSpace rest1 of - (space,rest2) -> Just (name++space,rest2) -capitalized' not s = Nothing - -tag i - | i < 0 = char 'r' <> int (negate i) - | otherwise = char 'n' <> int i - - -readProbabilitiesFromFile :: FilePath -> IO (Map.Map String Double) -readProbabilitiesFromFile fpath = do - s <- readFile fpath - return $ Map.fromList [(f,read p) | f:p:_ <- map words (lines s)] diff --git a/src/runtime/haskell/PGF2/Expr.hsc b/src/runtime/haskell/PGF2/Expr.hsc index 04499a183..786794725 100644 --- a/src/runtime/haskell/PGF2/Expr.hsc +++ b/src/runtime/haskell/PGF2/Expr.hsc @@ -2,310 +2,3 @@ module PGF2.Expr where -import System.IO.Unsafe(unsafePerformIO) -import Foreign hiding (unsafePerformIO) -import Foreign.C -import Data.IORef -import Data.Data -import PGF2.FFI -import Data.Maybe(fromJust) - -type Cat = String -- ^ Name of syntactic category -type Fun = String -- ^ Name of function - -data BindType = - Explicit - | Implicit - deriving (Show, Eq, Ord) - ------------------------------------------------------------------------------ --- Expressions - --- The C structure for the expression may point to other structures --- which are allocated from other pools. In order to ensure that --- they are not released prematurely we use the exprMaster to --- store references to other Haskell objects - -data Expr = Expr {expr :: PgfExpr, touchExpr :: Touch} - -instance Show Expr where - show = showExpr [] - -instance Eq Expr where - (Expr e1 e1_touch) == (Expr e2 e2_touch) = - unsafePerformIO $ do - res <- pgf_expr_eq e1 e2 - e1_touch >> e2_touch - return (res /= 0) - -instance Data Expr where - gfoldl f z e = z (fromJust . readExpr) `f` (showExpr [] e) - toConstr _ = readExprConstr - gunfold k z c = case constrIndex c of - 1 -> k (z (fromJust . readExpr)) - _ -> error "gunfold" - dataTypeOf _ = exprDataType - -readExprConstr :: Constr -readExprConstr = mkConstr exprDataType "(fromJust . readExpr)" [] Prefix - -exprDataType :: DataType -exprDataType = mkDataType "PGF2.Expr" [readExprConstr] - --- | Constructs an expression by lambda abstraction -mkAbs :: BindType -> String -> Expr -> Expr -mkAbs bind_type var (Expr body bodyTouch) = - unsafePerformIO $ do - exprPl <- gu_new_pool - cvar <- newUtf8CString var exprPl - c_expr <- pgf_expr_abs cbind_type cvar body exprPl - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr (bodyTouch >> touchForeignPtr exprFPl)) - where - cbind_type = - case bind_type of - Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) - Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) - --- | Decomposes an expression into an abstraction and a body -unAbs :: Expr -> Maybe (BindType, String, Expr) -unAbs (Expr expr touch) = - unsafePerformIO $ do - c_abs <- pgf_expr_unabs expr - if c_abs == nullPtr - then return Nothing - else do bt <- fmap toBindType ((#peek PgfExprAbs, bind_type) c_abs) - var <- (#peek PgfExprAbs, id) c_abs >>= peekUtf8CString - c_body <- (#peek PgfExprAbs, body) c_abs - return (Just (bt, var, Expr c_body touch)) - where - toBindType :: CInt -> BindType - toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit - toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit - --- | Constructs an expression by applying a function to a list of expressions -mkApp :: Fun -> [Expr] -> Expr -mkApp fun args = - unsafePerformIO $ - withCString fun $ \cfun -> - allocaBytes ((#size PgfApplication) + len * sizeOf (undefined :: PgfExpr)) $ \papp -> do - (#poke PgfApplication, fun) papp cfun - (#poke PgfApplication, n_args) papp len - pokeArray (papp `plusPtr` (#offset PgfApplication, args)) (map expr args) - exprPl <- gu_new_pool - c_expr <- pgf_expr_apply papp exprPl - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr (mapM_ touchExpr args >> touchForeignPtr exprFPl)) - where - len = length args - --- | Decomposes an expression into an application of a function -unApp :: Expr -> Maybe (Fun,[Expr]) -unApp (Expr expr touch) = - unsafePerformIO $ - withGuPool $ \pl -> do - appl <- pgf_expr_unapply expr pl - if appl == nullPtr - then return Nothing - else do - fun <- peekCString =<< (#peek PgfApplication, fun) appl - 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]) - --- | Decomposes an expression into an application of a function -unapply :: Expr -> (Expr,[Expr]) -unapply (Expr expr touch) = - unsafePerformIO $ - withGuPool $ \pl -> do - appl <- pgf_expr_unapply_ex expr pl - efun <- (#peek PgfApplication, efun) appl - arity <- (#peek PgfApplication, n_args) appl :: IO CInt - c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args)) - return (Expr efun touch, [Expr c_arg touch | c_arg <- c_args]) - --- | Constructs an expression from a string literal -mkStr :: String -> Expr -mkStr str = - unsafePerformIO $ - withCString str $ \cstr -> do - exprPl <- gu_new_pool - c_expr <- pgf_expr_string cstr exprPl - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr (touchForeignPtr exprFPl)) - --- | Decomposes an expression into a string literal -unStr :: Expr -> Maybe String -unStr (Expr expr touch) = - unsafePerformIO $ do - plit <- pgf_expr_unlit expr (#const PGF_LITERAL_STR) - if plit == nullPtr - then return Nothing - else do s <- peekUtf8CString (plit `plusPtr` (#offset PgfLiteralStr, val)) - touch - return (Just s) - --- | 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 - exprPl <- gu_new_pool - c_expr <- pgf_expr_int (fromIntegral val) exprPl - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr (touchForeignPtr exprFPl)) - --- | Decomposes an expression into an integer literal -unInt :: Expr -> Maybe Int -unInt (Expr expr touch) = - unsafePerformIO $ do - plit <- pgf_expr_unlit expr (#const PGF_LITERAL_INT) - if plit == nullPtr - then return Nothing - else do n <- peek (plit `plusPtr` (#offset PgfLiteralInt, val)) - touch - return (Just (fromIntegral (n :: CInt))) - --- | Constructs an expression from a real number -mkFloat :: Double -> Expr -mkFloat val = - unsafePerformIO $ do - exprPl <- gu_new_pool - c_expr <- pgf_expr_float (realToFrac val) exprPl - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr (touchForeignPtr exprFPl)) - --- | Decomposes an expression into a real number literal -unFloat :: Expr -> Maybe Double -unFloat (Expr expr touch) = - unsafePerformIO $ do - plit <- pgf_expr_unlit expr (#const PGF_LITERAL_FLT) - if plit == nullPtr - then return Nothing - else do n <- peek (plit `plusPtr` (#offset PgfLiteralFlt, val)) - touch - return (Just (realToFrac (n :: CDouble))) - --- | Constructs a meta variable as an expression -mkMeta :: Int -> Expr -mkMeta id = - unsafePerformIO $ do - exprPl <- gu_new_pool - c_expr <- pgf_expr_meta (fromIntegral id) exprPl - exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return (Expr c_expr (touchForeignPtr exprFPl)) - --- | Decomposes an expression into a meta variable -unMeta :: Expr -> Maybe Int -unMeta (Expr expr touch) = - unsafePerformIO $ do - c_meta <- pgf_expr_unmeta expr - if c_meta == nullPtr - then return Nothing - else do id <- (#peek PgfExprMeta, id) c_meta - touch - return (Just (fromIntegral (id :: CInt))) - --- | parses a 'String' as an expression -readExpr :: String -> Maybe Expr -readExpr str = - unsafePerformIO $ - do exprPl <- gu_new_pool - withGuPool $ \tmpPl -> - do c_str <- newUtf8CString str tmpPl - guin <- gu_string_in c_str tmpPl - exn <- gu_new_exn tmpPl - c_expr <- pgf_read_expr guin exprPl tmpPl exn - status <- gu_exn_is_raised exn - if (not status && c_expr /= nullPtr) - then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return $ Just (Expr c_expr (touchForeignPtr exprFPl)) - else do gu_pool_free exprPl - return Nothing - -pIdent :: ReadS String -pIdent str = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do ref <- newIORef (str,str,str) - exn <- gu_new_exn tmpPl - c_fetch_char <- wrapParserGetc (fetch_char ref) - c_parser <- pgf_new_parser nullPtr c_fetch_char tmpPl tmpPl exn - c_ident <- pgf_expr_parser_ident c_parser - status <- gu_exn_is_raised exn - if (not status && c_ident /= nullPtr) - then do ident <- peekUtf8CString c_ident - (str,_,_) <- readIORef ref - return [(ident,str)] - else do return [] - -pExpr :: ReadS Expr -pExpr str = - unsafePerformIO $ - do exprPl <- gu_new_pool - withGuPool $ \tmpPl -> - do ref <- newIORef (str,str,str) - exn <- gu_new_exn tmpPl - c_fetch_char <- wrapParserGetc (fetch_char ref) - c_parser <- pgf_new_parser nullPtr c_fetch_char exprPl tmpPl exn - c_expr <- pgf_expr_parser_expr c_parser 1 - status <- gu_exn_is_raised exn - if (not status && c_expr /= nullPtr) - then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl - (str,_,_) <- readIORef ref - return [(Expr c_expr (touchForeignPtr exprFPl),str)] - else do gu_pool_free exprPl - return [] - -fetch_char :: IORef (String,String,String) -> Ptr () -> (#type bool) -> Ptr GuExn -> IO (#type GuUCS) -fetch_char ref _ mark exn = do - (str1,str2,str3) <- readIORef ref - let str1' = if mark /= 0 - then str2 - else str1 - case str3 of - [] -> do writeIORef ref (str1',str3,[]) - gu_exn_raise exn gu_exn_type_GuEOF - return (-1) - (c:cs) -> do writeIORef ref (str1',str3,cs) - return ((fromIntegral . fromEnum) c) - -foreign import ccall "pgf/expr.h pgf_new_parser" - pgf_new_parser :: Ptr () -> (FunPtr ParserGetc) -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfExprParser) - -foreign import ccall "pgf/expr.h pgf_expr_parser_expr" - pgf_expr_parser_expr :: Ptr PgfExprParser -> (#type bool) -> IO PgfExpr - -foreign import ccall "pgf/expr.h pgf_expr_parser_ident" - pgf_expr_parser_ident :: Ptr PgfExprParser -> IO CString - -type ParserGetc = Ptr () -> (#type bool) -> Ptr GuExn -> IO (#type GuUCS) - -foreign import ccall "wrapper" - wrapParserGetc :: ParserGetc -> IO (FunPtr ParserGetc) - - --- | renders an expression as a 'String'. The list --- of identifiers is the list of all free variables --- in the expression in order reverse to the order --- of binding. -showExpr :: [String] -> Expr -> String -showExpr scope e = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - printCtxt <- newPrintCtxt scope tmpPl - exn <- gu_new_exn tmpPl - pgf_print_expr (expr e) printCtxt 1 out exn - touchExpr e - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s - -newPrintCtxt :: [String] -> Ptr GuPool -> IO (Ptr PgfPrintContext) -newPrintCtxt [] pool = return nullPtr -newPrintCtxt (x:xs) pool = do - pctxt <- gu_malloc pool (#size PgfPrintContext) - newUtf8CString x pool >>= (#poke PgfPrintContext, name) pctxt - newPrintCtxt xs pool >>= (#poke PgfPrintContext, next) pctxt - return pctxt diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 7017958d7..e66baefa3 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -2,568 +2,26 @@ module PGF2.FFI where -#include -#include -#include -#include -#include - -import Foreign ( alloca, peek, poke, peekByteOff ) import Foreign.C import Foreign.Ptr import Foreign.ForeignPtr -import Control.Exception -import GHC.Ptr -import Data.Int -import Data.Word import qualified Data.Map as Map -type Touch = IO () - -- | An abstract data type representing multilingual grammar -- in Portable Grammar Format. -data PGF = PGF {pgf :: Ptr PgfPGF, langs :: Map.Map String Concr, touchPGF :: Touch} -data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch} - ------------------------------------------------------------------- --- libgu API - -data GuEnum -data GuExn -data GuIn -data GuOut -data GuKind -data GuType -data GuStringBuf -data GuMap -data GuMapItor -data GuHasher -data GuSeq -data GuBuf -data GuPool -type GuVariant = Ptr () -type GuHash = (#type GuHash) -type GuUCS = (#type GuUCS) - -type CSizeT = (#type size_t) -type CUInt8 = (#type uint8_t) - -foreign import ccall unsafe fopen :: CString -> CString -> IO (Ptr ()) - -foreign import ccall unsafe "gu/mem.h gu_new_pool" - gu_new_pool :: IO (Ptr GuPool) - -foreign import ccall unsafe "gu/mem.h gu_malloc" - gu_malloc :: Ptr GuPool -> CSizeT -> IO (Ptr a) - -foreign import ccall unsafe "gu/mem.h gu_malloc_aligned" - gu_malloc_aligned :: Ptr GuPool -> CSizeT -> CSizeT -> IO (Ptr a) - -foreign import ccall unsafe "gu/mem.h gu_pool_free" - gu_pool_free :: Ptr GuPool -> IO () - -foreign import ccall unsafe "gu/mem.h &gu_pool_free" - gu_pool_finalizer :: FinalizerPtr GuPool - -foreign import ccall unsafe "gu/exn.h gu_new_exn" - gu_new_exn :: Ptr GuPool -> IO (Ptr GuExn) - -foreign import ccall unsafe "gu/exn.h gu_exn_is_raised" - gu_exn_is_raised :: Ptr GuExn -> IO Bool - -foreign import ccall unsafe "gu/exn.h gu_exn_caught_" - gu_exn_caught :: Ptr GuExn -> CString -> IO Bool - -foreign import ccall unsafe "gu/exn.h gu_exn_raise_" - gu_exn_raise :: Ptr GuExn -> CString -> IO (Ptr ()) - -gu_exn_type_GuErrno = Ptr "GuErrno"## :: CString - -gu_exn_type_GuEOF = Ptr "GuEOF"## :: CString - -gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"## :: CString - -gu_exn_type_PgfExn = Ptr "PgfExn"## :: CString - -gu_exn_type_PgfParseError = Ptr "PgfParseError"## :: CString - -gu_exn_type_PgfTypeError = Ptr "PgfTypeError"## :: CString - -foreign import ccall unsafe "gu/string.h gu_string_in" - gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn) - -foreign import ccall unsafe "gu/string.h gu_new_string_buf" - gu_new_string_buf :: Ptr GuPool -> IO (Ptr GuStringBuf) - -foreign import ccall unsafe "gu/string.h gu_string_buf_out" - gu_string_buf_out :: Ptr GuStringBuf -> IO (Ptr GuOut) - -foreign import ccall unsafe "gu/file.h gu_file_in" - gu_file_in :: Ptr () -> Ptr GuPool -> IO (Ptr GuIn) - -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 - -foreign import ccall unsafe "gu/utf8.h gu_utf8_decode" - gu_utf8_decode :: Ptr CString -> IO GuUCS - -foreign import ccall unsafe "gu/utf8.h gu_utf8_encode" - gu_utf8_encode :: GuUCS -> Ptr CString -> IO () - -foreign import ccall unsafe "gu/seq.h gu_make_seq" - gu_make_seq :: CSizeT -> CSizeT -> Ptr GuPool -> IO (Ptr GuSeq) - -foreign import ccall unsafe "gu/seq.h gu_make_buf" - gu_make_buf :: CSizeT -> Ptr GuPool -> IO (Ptr GuBuf) - -foreign import ccall unsafe "gu/map.h gu_make_map" - gu_make_map :: CSizeT -> Ptr GuHasher -> CSizeT -> Ptr a -> CSizeT -> Ptr GuPool -> IO (Ptr GuMap) - -foreign import ccall unsafe "gu/map.h gu_map_insert" - gu_map_insert :: Ptr GuMap -> Ptr a -> IO (Ptr b) - -foreign import ccall unsafe "gu/map.h gu_map_find_default" - gu_map_find_default :: Ptr GuMap -> Ptr a -> IO (Ptr b) - -foreign import ccall "gu/map.h gu_map_iter" - gu_map_iter :: Ptr GuMap -> Ptr GuMapItor -> Ptr GuExn -> IO () - -foreign import ccall unsafe "gu/hash.h &gu_int_hasher" - gu_int_hasher :: Ptr GuHasher - -foreign import ccall unsafe "gu/hash.h &gu_addr_hasher" - gu_addr_hasher :: Ptr GuHasher - -foreign import ccall unsafe "gu/hash.h &gu_string_hasher" - gu_string_hasher :: Ptr GuHasher - -foreign import ccall unsafe "gu/hash.h &gu_null_struct" - gu_null_struct :: Ptr a - -foreign import ccall unsafe "gu/variant.h gu_variant_tag" - gu_variant_tag :: GuVariant -> IO CInt - -foreign import ccall unsafe "gu/variant.h gu_variant_data" - gu_variant_data :: GuVariant -> IO (Ptr a) - -foreign import ccall unsafe "gu/variant.h gu_alloc_variant" - gu_alloc_variant :: CUInt8 -> CSizeT -> CSizeT -> Ptr GuVariant -> Ptr GuPool -> IO (Ptr a) - - -withGuPool :: (Ptr GuPool -> IO a) -> IO a -withGuPool f = bracket gu_new_pool gu_pool_free f - -newOut :: Ptr GuPool -> IO (Ptr GuStringBuf, Ptr GuOut) -newOut pool = - do sb <- gu_new_string_buf pool - out <- gu_string_buf_out sb - return (sb,out) - -peekUtf8CString :: CString -> IO String -peekUtf8CString ptr = - alloca $ \pptr -> - poke pptr ptr >> decode pptr - where - decode pptr = do - x <- gu_utf8_decode pptr - if x == 0 - then return [] - else do cs <- decode pptr - return (((toEnum . fromEnum) x) : cs) - -peekUtf8CStringLen :: CString -> CInt -> IO String -peekUtf8CStringLen ptr len = - alloca $ \pptr -> - poke pptr ptr >> decode pptr (ptr `plusPtr` fromIntegral len) - where - decode pptr end = do - ptr <- peek pptr - if ptr >= end - then return [] - else do x <- gu_utf8_decode pptr - cs <- decode pptr end - return (((toEnum . fromEnum) x) : cs) - -pokeUtf8CString :: String -> CString -> IO () -pokeUtf8CString s ptr = - alloca $ \pptr -> - poke pptr ptr >> encode s pptr - where - encode [] pptr = do - gu_utf8_encode 0 pptr - encode (c:cs) pptr = do - gu_utf8_encode ((toEnum . fromEnum) c) pptr - encode cs pptr - -newUtf8CString :: String -> Ptr GuPool -> IO CString -newUtf8CString s pool = do - ptr <- gu_malloc pool (fromIntegral (utf8Length s)) - pokeUtf8CString s ptr - return ptr - -utf8Length s = count 0 s - where - count !c [] = c+1 - count !c (x:xs) - | ucs < 0x80 = count (c+1) xs - | ucs < 0x800 = count (c+2) xs - | ucs < 0x10000 = count (c+3) xs - | ucs < 0x200000 = count (c+4) xs - | ucs < 0x4000000 = count (c+5) xs - | otherwise = count (c+6) xs - where - ucs = fromEnum x - -peekSequence peekElem size ptr = do - c_len <- (#peek GuSeq, len) ptr - peekElems (c_len :: CSizeT) (ptr `plusPtr` (#offset GuSeq, data)) - where - peekElems 0 ptr = return [] - peekElems len ptr = do - e <- peekElem ptr - es <- peekElems (len-1) (ptr `plusPtr` size) - return (e:es) - -newSequence :: CSizeT -> (Ptr a -> v -> IO ()) -> [v] -> Ptr GuPool -> IO (Ptr GuSeq) -newSequence elem_size pokeElem values pool = do - c_seq <- gu_make_seq elem_size (fromIntegral (length values)) pool - pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) values - return c_seq - where - pokeElems ptr [] = return () - pokeElems ptr (x:xs) = 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 +data PGF = PGF {a_pgf :: ForeignPtr PgfPGF, langs :: Map.Map String Concr} +data Concr = Concr {c_pgf :: ForeignPtr PgfPGF, concr :: Ptr PgfConcr} ------------------------------------------------------------------ -- libpgf API +data PgfExn data PgfPGF -data PgfApplication data PgfConcr -type PgfExpr = Ptr () -data PgfExprProb -data PgfTokenProb -data PgfExprParser -data PgfFullFormEntry -data PgfMorphoCallback -data PgfPrintContext -type PgfType = Ptr () -data PgfCallbacksMap -data PgfOracleCallback -data PgfCncTree -data PgfLinFuncs -data PgfGraphvizOptions -type PgfBindType = (#type PgfBindType) -data PgfAbsFun -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) +foreign import ccall "pgf.h pgf_read" + pgf_read :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF) -foreign import ccall "pgf/pgf.h pgf_write" - pgf_write :: Ptr PgfPGF -> CSizeT -> Ptr (Ptr PgfConcr) -> CString -> Ptr GuExn -> IO () +foreign import ccall "&pgf_free" + pgf_free_fptr :: FinalizerPtr PgfPGF -foreign import ccall "pgf/writer.h pgf_concrete_save" - pgf_concrete_save :: Ptr PgfConcr -> CString -> Ptr GuExn -> IO () - -foreign import ccall "pgf/pgf.h pgf_have_same_abstract" - pgf_have_same_abstract :: Ptr PgfPGF -> Ptr PgfPGF -> (#type bool) - -foreign import ccall "pgf/pgf.h pgf_abstract_name" - pgf_abstract_name :: Ptr PgfPGF -> IO CString - -foreign import ccall "pgf/pgf.h pgf_iter_languages" - pgf_iter_languages :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO () - -foreign import ccall "pgf/pgf.h pgf_get_language" - pgf_get_language :: Ptr PgfPGF -> CString -> IO (Ptr PgfConcr) - -foreign import ccall "pgf/pgf.h pgf_concrete_name" - pgf_concrete_name :: Ptr PgfConcr -> IO CString - -foreign import ccall "pgf/pgf.h pgf_concrete_load" - pgf_concrete_load :: Ptr PgfConcr -> Ptr GuIn -> Ptr GuExn -> IO () - -foreign import ccall "pgf/pgf.h pgf_concrete_unload" - pgf_concrete_unload :: Ptr PgfConcr -> IO () - -foreign import ccall "pgf/pgf.h pgf_language_code" - pgf_language_code :: Ptr PgfConcr -> IO CString - -foreign import ccall "pgf/pgf.h pgf_iter_categories" - pgf_iter_categories :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO () - -foreign import ccall "pgf/pgf.h pgf_concrete_fix_internals" - pgf_concrete_fix_internals :: Ptr PgfConcr -> IO () - -foreign import ccall "pgf/pgf.h pgf_start_cat" - pgf_start_cat :: Ptr PgfPGF -> Ptr GuPool -> IO PgfType - -foreign import ccall "pgf/pgf.h pgf_category_context" - pgf_category_context :: Ptr PgfPGF -> CString -> IO (Ptr GuSeq) - -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 () - -foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat" - pgf_iter_functions_by_cat :: Ptr PgfPGF -> CString -> Ptr GuMapItor -> Ptr GuExn -> IO () - -foreign import ccall "pgf/pgf.h pgf_function_type" - pgf_function_type :: Ptr PgfPGF -> CString -> IO PgfType - -foreign import ccall "pgf/expr.h pgf_function_is_constructor" - pgf_function_is_constructor :: Ptr PgfPGF -> CString -> IO (#type bool) - -foreign import ccall "pgf/pgf.h pgf_print_name" - pgf_print_name :: Ptr PgfConcr -> CString -> IO CString - -foreign import ccall "pgf/pgf.h pgf_has_linearization" - pgf_has_linearization :: Ptr PgfConcr -> CString -> IO CInt - -foreign import ccall "pgf/pgf.h pgf_linearize" - pgf_linearize :: Ptr PgfConcr -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO () - -foreign import ccall "pgf/pgf.h pgf_lzr_concretize" - pgf_lzr_concretize :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuEnum) - -foreign import ccall "pgf/pgf.h pgf_lzr_wrap_linref" - pgf_lzr_wrap_linref :: Ptr PgfCncTree -> Ptr GuPool -> IO (Ptr PgfCncTree) - -foreign import ccall "pgf/pgf.h pgf_lzr_linearize_simple" - pgf_lzr_linearize_simple :: Ptr PgfConcr -> Ptr PgfCncTree -> CSizeT -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO () - -foreign import ccall "pgf/pgf.h pgf_lzr_linearize" - pgf_lzr_linearize :: Ptr PgfConcr -> Ptr PgfCncTree -> CSizeT -> Ptr (Ptr PgfLinFuncs) -> Ptr GuPool -> IO () - -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 -> 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" - wrapSymbolTokenCallback :: SymbolTokenCallback -> IO (FunPtr SymbolTokenCallback) - -foreign import ccall "wrapper" - wrapPhraseCallback :: PhraseCallback -> IO (FunPtr PhraseCallback) - -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_lookup_sentence" - pgf_lookup_sentence :: Ptr PgfConcr -> PgfType -> CString -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum) - -type LiteralMatchCallback = CString -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb) - -foreign import ccall "wrapper" - wrapLiteralMatchCallback :: LiteralMatchCallback -> IO (FunPtr LiteralMatchCallback) - -type LiteralPredictCallback = CString -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb) - -foreign import ccall "wrapper" - wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback) - -foreign import ccall "pgf/pgf.h pgf_new_callbacks_map" - pgf_new_callbacks_map :: Ptr PgfConcr -> Ptr GuPool -> IO (Ptr PgfCallbacksMap) - -foreign import ccall - hspgf_callbacks_map_add_literal :: Ptr PgfConcr -> Ptr PgfCallbacksMap -> CString -> FunPtr LiteralMatchCallback -> FunPtr LiteralPredictCallback -> Ptr GuPool -> IO () - -type OracleCallback = CString -> CString -> CSizeT -> IO Bool -type OracleLiteralCallback = CString -> CString -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb) - -foreign import ccall "wrapper" - wrapOracleCallback :: OracleCallback -> IO (FunPtr OracleCallback) - -foreign import ccall "wrapper" - wrapOracleLiteralCallback :: OracleLiteralCallback -> IO (FunPtr OracleLiteralCallback) - -foreign import ccall - hspgf_new_oracle_callback :: CString -> FunPtr OracleCallback -> FunPtr OracleCallback -> FunPtr OracleLiteralCallback -> Ptr GuPool -> IO (Ptr PgfOracleCallback) - -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 () - -foreign import ccall "pgf/pgf.h pgf_lookup_cohorts" - pgf_lookup_cohorts :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuEnum) - -type LookupMorphoCallback = Ptr PgfMorphoCallback -> CString -> CString -> Float -> Ptr GuExn -> IO () - -foreign import ccall "wrapper" - wrapLookupMorphoCallback :: LookupMorphoCallback -> IO (FunPtr LookupMorphoCallback) - -type MapItorCallback = Ptr GuMapItor -> Ptr () -> Ptr () -> Ptr GuExn -> IO () - -foreign import ccall "wrapper" - wrapMapItorCallback :: MapItorCallback -> IO (FunPtr MapItorCallback) - -foreign import ccall "pgf/pgf.h pgf_fullform_lexicon" - pgf_fullform_lexicon :: Ptr PgfConcr -> Ptr GuPool -> IO (Ptr GuEnum) - -foreign import ccall "pgf/pgf.h pgf_fullform_get_string" - pgf_fullform_get_string :: Ptr PgfFullFormEntry -> IO CString - -foreign import ccall "pgf/pgf.h pgf_fullform_get_analyses" - pgf_fullform_get_analyses :: Ptr PgfFullFormEntry -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO () - -foreign import ccall "pgf/pgf.h pgf_expr_apply" - pgf_expr_apply :: Ptr PgfApplication -> Ptr GuPool -> IO PgfExpr - -foreign import ccall "pgf/pgf.h pgf_expr_unapply" - pgf_expr_unapply :: PgfExpr -> Ptr GuPool -> IO (Ptr PgfApplication) - -foreign import ccall "pgf/pgf.h pgf_expr_unapply_ex" - pgf_expr_unapply_ex :: PgfExpr -> Ptr GuPool -> IO (Ptr PgfApplication) - -foreign import ccall "pgf/pgf.h pgf_expr_abs" - pgf_expr_abs :: PgfBindType -> CString -> PgfExpr -> Ptr GuPool -> IO PgfExpr - -foreign import ccall "pgf/pgf.h pgf_expr_unabs" - pgf_expr_unabs :: PgfExpr -> IO (Ptr a) - -foreign import ccall "pgf/pgf.h pgf_expr_meta" - pgf_expr_meta :: CInt -> Ptr GuPool -> IO PgfExpr - -foreign import ccall "pgf/pgf.h pgf_expr_unmeta" - pgf_expr_unmeta :: PgfExpr -> IO (Ptr a) - -foreign import ccall "pgf/pgf.h pgf_expr_string" - pgf_expr_string :: CString -> Ptr GuPool -> IO PgfExpr - -foreign import ccall "pgf/pgf.h pgf_expr_int" - pgf_expr_int :: CInt -> Ptr GuPool -> IO PgfExpr - -foreign import ccall "pgf/pgf.h pgf_expr_float" - pgf_expr_float :: CDouble -> Ptr GuPool -> IO PgfExpr - -foreign import ccall "pgf/pgf.h pgf_expr_unlit" - pgf_expr_unlit :: PgfExpr -> CInt -> IO (Ptr a) - -foreign import ccall "pgf/expr.h pgf_expr_eq" - pgf_expr_eq :: PgfExpr -> PgfExpr -> IO CInt - -foreign import ccall "pgf/expr.h pgf_type_eq" - pgf_type_eq :: PgfType -> PgfType -> IO (#type bool) - -foreign import ccall "pgf/expr.h pgf_expr_hash" - pgf_expr_hash :: GuHash -> PgfExpr -> IO GuHash - -foreign import ccall "pgf/expr.h pgf_expr_size" - pgf_expr_size :: PgfExpr -> IO CInt - -foreign import ccall "pgf/expr.h pgf_expr_functions" - pgf_expr_functions :: PgfExpr -> Ptr GuPool -> IO (Ptr GuSeq) - -foreign import ccall "pgf/expr.h pgf_expr_substitute" - pgf_expr_substitute :: PgfExpr -> Ptr GuSeq -> Ptr GuPool -> IO PgfExpr - -foreign import ccall "pgf/expr.h pgf_compute_tree_probability" - pgf_compute_tree_probability :: Ptr PgfPGF -> PgfExpr -> IO CFloat - -foreign import ccall "pgf/expr.h pgf_check_expr" - pgf_check_expr :: Ptr PgfPGF -> Ptr PgfExpr -> PgfType -> Ptr GuExn -> Ptr GuPool -> IO () - -foreign import ccall "pgf/expr.h pgf_infer_expr" - pgf_infer_expr :: Ptr PgfPGF -> Ptr PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO PgfType - -foreign import ccall "pgf/expr.h pgf_check_type" - pgf_check_type :: Ptr PgfPGF -> Ptr PgfType -> Ptr GuExn -> Ptr GuPool -> IO () - -foreign import ccall "pgf/expr.h pgf_compute" - pgf_compute :: Ptr PgfPGF -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO PgfExpr - -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_type" - pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO () - -foreign import ccall "pgf/expr.h pgf_print_context" - pgf_print_context :: Ptr GuSeq -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO () - -foreign import ccall "pgf/pgf.h pgf_generate_all" - pgf_generate_all :: Ptr PgfPGF -> PgfType -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum) - -foreign import ccall "pgf/pgf.h pgf_print" - pgf_print :: Ptr PgfPGF -> CSizeT -> Ptr (Ptr PgfConcr) -> Ptr GuOut -> Ptr GuExn -> IO () - -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_type" - pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfType - -foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree" - pgf_graphviz_abstract_tree :: Ptr PgfPGF -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () - -foreign import ccall "pgf/graphviz.h pgf_graphviz_parse_tree" - pgf_graphviz_parse_tree :: Ptr PgfConcr -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () - -foreign import ccall "pgf/graphviz.h pgf_graphviz_word_alignment" - pgf_graphviz_word_alignment :: Ptr (Ptr PgfConcr) -> CSizeT -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () - -foreign import ccall "pgf/data.h pgf_parser_index" - pgf_parser_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO () - -foreign import ccall "pgf/data.h pgf_lzr_index" - pgf_lzr_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO () - -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/PGF2/Internal.hsc b/src/runtime/haskell/PGF2/Internal.hsc index 556ae5482..67d7b4d9c 100644 --- a/src/runtime/haskell/PGF2/Internal.hsc +++ b/src/runtime/haskell/PGF2/Internal.hsc @@ -1,1037 +1,4 @@ {-# LANGUAGE ImplicitParams, RankNTypes #-} module PGF2.Internal(-- * Access the internal structures - FId,isPredefFId, - FunId,SeqId,LIndex,Token,Production(..),PArg(..),Symbol(..),Literal(..), - globalFlags, abstrFlags, concrFlags, - concrTotalCats, concrCategories, concrProductions, - concrTotalFuns, concrFunction, - concrTotalSeqs, concrSequence, - - -- * Byte code - CodeLabel, Instr(..), IVal(..), TailInfo(..), - - -- * Building new PGFs in memory - build, Builder, B, - eAbs, eApp, eMeta, eFun, eVar, eLit, eTyped, eImplArg, dTyp, hypo, - AbstrInfo, newAbstr, ConcrInfo, newConcr, newPGF, - - -- * Expose PGF and Concr for FFI with C - PGF(..), Concr(..), - - -- * Write an in-memory PGF to a file - unionPGF, writePGF, writeConcr, - - -- * Predefined concrete categories - fidString, fidInt, fidFloat, fidVar, fidStart ) where - -#include - -import PGF2 -import PGF2.FFI -import PGF2.Expr -import PGF2.Type -import System.IO.Unsafe(unsafePerformIO) -import Foreign -import Foreign.C -import Data.IORef -import Data.Maybe(fromMaybe) -import Data.List(sortBy) -import Control.Exception(Exception,throwIO) -import Control.Monad(foldM,when) -import qualified Data.Map as Map - -type Token = String -type LIndex = Int -data Symbol - = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex - | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex - | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int - | SymKS Token - | SymKP [Symbol] [([Symbol],[String])] - | SymBIND -- the special BIND token - | SymNE -- non exist - | SymSOFT_BIND -- the special SOFT_BIND token - | SymSOFT_SPACE -- the special SOFT_SPACE token - | SymCAPIT -- the special CAPIT token - | SymALL_CAPIT -- the special ALL_CAPIT token - deriving (Eq,Ord,Show) -data Production - = PApply {-# UNPACK #-} !FunId [PArg] - | PCoerce {-# UNPACK #-} !FId - deriving (Eq,Ord,Show) - -type FunId = Int -type SeqId = Int -data Literal = - LStr String -- ^ a string constant - | LInt Int -- ^ an integer constant - | LFlt Double -- ^ a floating point constant - deriving (Eq,Ord,Show) - -type CodeLabel = Int - -data Instr - = CHECK_ARGS {-# UNPACK #-} !Int - | CASE Fun {-# UNPACK #-} !CodeLabel - | CASE_LIT Literal {-# UNPACK #-} !CodeLabel - | SAVE {-# UNPACK #-} !Int - | ALLOC {-# UNPACK #-} !Int - | PUT_CONSTR Fun - | PUT_CLOSURE {-# UNPACK #-} !CodeLabel - | PUT_LIT Literal - | SET IVal - | SET_PAD - | PUSH_FRAME - | PUSH IVal - | TUCK IVal {-# UNPACK #-} !Int - | EVAL IVal TailInfo - | DROP {-# UNPACK #-} !Int - | JUMP {-# UNPACK #-} !CodeLabel - | FAIL - | PUSH_ACCUM Literal - | POP_ACCUM - | ADD - -data IVal - = HEAP {-# UNPACK #-} !Int - | ARG_VAR {-# UNPACK #-} !Int - | FREE_VAR {-# UNPACK #-} !Int - | GLOBAL Fun - deriving Eq - -data TailInfo - = RecCall - | TailCall {-# UNPACK #-} !Int - | UpdateCall - - ------------------------------------------------------------------------ --- Access the internal structures ------------------------------------------------------------------------ - -globalFlags :: PGF -> [(String,Literal)] -globalFlags p = unsafePerformIO $ do - c_flags <- (#peek PgfPGF, gflags) (pgf p) - flags <- peekFlags c_flags - touchPGF p - return flags - -abstrFlags :: PGF -> [(String,Literal)] -abstrFlags p = unsafePerformIO $ do - c_flags <- (#peek PgfPGF, abstract.aflags) (pgf p) - flags <- peekFlags c_flags - touchPGF p - return flags - -concrFlags :: Concr -> [(String,Literal)] -concrFlags c = unsafePerformIO $ do - c_flags <- (#peek PgfConcr, cflags) (concr c) - flags <- peekFlags c_flags - touchConcr c - return flags - -peekFlags :: Ptr GuSeq -> IO [(String,Literal)] -peekFlags c_flags = do - c_len <- (#peek GuSeq, len) c_flags - peekFlags (c_len :: CInt) (c_flags `plusPtr` (#offset GuSeq, data)) - where - peekFlags 0 ptr = return [] - peekFlags c_len ptr = do - name <- (#peek PgfFlag, name) ptr >>= peekUtf8CString - value <- (#peek PgfFlag, value) ptr >>= peekLiteral - flags <- peekFlags (c_len-1) (ptr `plusPtr` (#size PgfFlag)) - return ((name,value):flags) - -peekLiteral :: GuVariant -> IO Literal -peekLiteral p = do - tag <- gu_variant_tag p - ptr <- gu_variant_data p - case tag of - (#const PGF_LITERAL_STR) -> do { val <- peekUtf8CString (ptr `plusPtr` (#offset PgfLiteralStr, val)); - return (LStr val) } - (#const PGF_LITERAL_INT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralInt, val)); - return (LInt (fromIntegral (val :: CInt))) } - (#const PGF_LITERAL_FLT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralFlt, val)); - return (LFlt (realToFrac (val :: CDouble))) } - _ -> error "Unknown literal type in the grammar" - -concrTotalCats :: Concr -> FId -concrTotalCats c = unsafePerformIO $ do - c_total_cats <- (#peek PgfConcr, total_cats) (concr c) - touchConcr c - return (fromIntegral (c_total_cats :: CInt)) - -concrCategories :: Concr -> [(Cat,FId,FId,[String])] -concrCategories c = - unsafePerformIO $ - withGuPool $ \tmpPl -> - allocaBytes (#size GuMapItor) $ \itor -> do - exn <- gu_new_exn tmpPl - ref <- newIORef [] - fptr <- wrapMapItorCallback (getCategories ref) - (#poke GuMapItor, fn) itor fptr - c_cnccats <- (#peek PgfConcr, cnccats) (concr c) - gu_map_iter c_cnccats itor exn - touchConcr c - freeHaskellFunPtr fptr - cs <- readIORef ref - return (reverse cs) - where - getCategories ref itor key value exn = do - names <- readIORef ref - name <- peekUtf8CString (castPtr key) - c_cnccat <- peek (castPtr value) - c_cats <- (#peek PgfCncCat, cats) c_cnccat - c_len <- (#peek GuSeq, len) c_cats - first <- peek (c_cats `plusPtr` (#offset GuSeq, data)) >>= peekFId - last <- peek (c_cats `plusPtr` ((#offset GuSeq, data) + (fromIntegral (c_len-1::CSizeT))*(#size PgfCCat*))) >>= peekFId - c_n_lins <- (#peek PgfCncCat, n_lins) c_cnccat - arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cnccat `plusPtr` (#offset PgfCncCat, labels)) - labels <- mapM peekUtf8CString arr - writeIORef ref ((name,first,last,labels) : names) - -concrProductions :: Concr -> FId -> [Production] -concrProductions c fid = unsafePerformIO $ do - c_ccats <- (#peek PgfConcr, ccats) (concr c) - res <- alloca $ \pfid -> do - poke pfid (fromIntegral fid :: CInt) - gu_map_find_default c_ccats pfid >>= peek - if res == nullPtr - then do touchConcr c - return [] - else do c_prods <- (#peek PgfCCat, prods) res - if c_prods == nullPtr - then do touchConcr c - return [] - else do res <- peekSequence (deRef peekProduction) (#size GuVariant) c_prods - touchConcr c - return res - where - peekProduction 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_funid <- (#peek PgfCncFun, funid) c_cncfun ; - c_args <- (#peek PgfProductionApply, args) dt ; - pargs <- peekSequence peekPArg (#size PgfPArg) c_args ; - return (PApply (fromIntegral (c_funid :: CInt)) pargs) } - (#const PGF_PRODUCTION_COERCE)-> do { c_coerce <- (#peek PgfProductionCoerce, coerce) dt ; - fid <- peekFId c_coerce ; - return (PCoerce fid) } - _ -> error "Unknown production type in the grammar" - where - peekPArg ptr = do - c_hypos <- (#peek PgfPArg, hypos) ptr - hypos <- peekSequence (deRef peekFId) (#size int) c_hypos - c_ccat <- (#peek PgfPArg, ccat) ptr - fid <- peekFId c_ccat - return (PArg [(fid,fid) | fid <- hypos] fid) - -concrTotalFuns :: Concr -> FunId -concrTotalFuns c = unsafePerformIO $ do - c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c) - c_len <- (#peek GuSeq, len) c_cncfuns - touchConcr c - return (fromIntegral (c_len :: CSizeT)) - -concrFunction :: Concr -> FunId -> (Fun,[SeqId]) -concrFunction c funid = unsafePerformIO $ do - c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c) - c_len <- (#peek GuSeq, len) c_cncfuns - when (funid >= fromIntegral (c_len :: CSizeT)) $ - throwIO (PGFError ("Invalid concrete function: F"++show funid)) - c_cncfun <- peek (c_cncfuns `plusPtr` ((#offset GuSeq, data)+funid*(#size PgfCncFun*))) - c_absfun <- (#peek PgfCncFun, absfun) c_cncfun - c_name <- (#peek PgfAbsFun, name) c_absfun - name <- peekUtf8CString c_name - c_n_lins <- (#peek PgfCncFun, n_lins) c_cncfun - arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cncfun `plusPtr` (#offset PgfCncFun, lins)) - seqs_seq <- (#peek PgfConcr, sequences) (concr c) - touchConcr c - let seqs = seqs_seq `plusPtr` (#offset GuSeq, data) - return (name, map (toSeqId seqs) arr) - where - toSeqId seqs seq = minusPtr seq seqs `div` (#size PgfSequence) - -concrTotalSeqs :: Concr -> SeqId -concrTotalSeqs c = unsafePerformIO $ do - seq <- (#peek PgfConcr, sequences) (concr c) - c_len <- (#peek GuSeq, len) seq - touchConcr c - return (fromIntegral (c_len :: CSizeT)) - -concrSequence :: Concr -> SeqId -> [Symbol] -concrSequence c seqid = unsafePerformIO $ do - c_sequences <- (#peek PgfConcr, sequences) (concr c) - c_len <- (#peek GuSeq, len) c_sequences - when (seqid >= fromIntegral (c_len :: CSizeT)) $ - throwIO (PGFError ("Invalid concrete sequence: S"++show seqid)) - let c_sequence = c_sequences `plusPtr` ((#offset GuSeq, data)+seqid*(#size PgfSequence)) - c_syms <- (#peek PgfSequence, syms) c_sequence - res <- peekSequence (deRef peekSymbol) (#size GuVariant) c_syms - touchConcr c - return res - where - peekSymbol p = do - tag <- gu_variant_tag p - dt <- gu_variant_data p - case tag of - (#const PGF_SYMBOL_CAT) -> peekSymbolIdx SymCat dt - (#const PGF_SYMBOL_LIT) -> peekSymbolIdx SymLit dt - (#const PGF_SYMBOL_VAR) -> peekSymbolIdx SymVar dt - (#const PGF_SYMBOL_KS) -> peekSymbolKS dt - (#const PGF_SYMBOL_KP) -> peekSymbolKP dt - (#const PGF_SYMBOL_BIND) -> return SymBIND - (#const PGF_SYMBOL_SOFT_BIND) -> return SymSOFT_BIND - (#const PGF_SYMBOL_NE) -> return SymNE - (#const PGF_SYMBOL_SOFT_SPACE) -> return SymSOFT_SPACE - (#const PGF_SYMBOL_CAPIT) -> return SymCAPIT - (#const PGF_SYMBOL_ALL_CAPIT) -> return SymALL_CAPIT - _ -> error "Unknown symbol type in the grammar" - - peekSymbolIdx constr dt = do - c_d <- (#peek PgfSymbolIdx, d) dt - c_r <- (#peek PgfSymbolIdx, r) dt - return (constr (fromIntegral (c_d :: CInt)) (fromIntegral (c_r :: CInt))) - - peekSymbolKS dt = do - token <- peekUtf8CString (dt `plusPtr` (#offset PgfSymbolKS, token)) - return (SymKS token) - - peekSymbolKP dt = do - c_default_form <- (#peek PgfSymbolKP, default_form) dt - default_form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_default_form - c_n_forms <- (#peek PgfSymbolKP, n_forms) dt - forms <- peekForms (c_n_forms :: CSizeT) (dt `plusPtr` (#offset PgfSymbolKP, forms)) - return (SymKP default_form forms) - - peekForms 0 ptr = return [] - peekForms len ptr = do - c_form <- (#peek PgfAlternative, form) ptr - form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_form - c_prefixes <- (#peek PgfAlternative, prefixes) ptr - prefixes <- peekSequence (deRef peekUtf8CString) (#size GuString*) c_prefixes - forms <- peekForms (len-1) (ptr `plusPtr` (#size PgfAlternative)) - return ((form,prefixes):forms) - -fidString, fidInt, fidFloat, fidVar, fidStart :: FId -fidString = (-1) -fidInt = (-2) -fidFloat = (-3) -fidVar = (-4) -fidStart = (-5) - -isPredefFId :: FId -> Bool -isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar]) - - ------------------------------------------------------------------------ --- Building new PGFs in memory ------------------------------------------------------------------------ - -data Builder s = Builder (Ptr GuPool) Touch -newtype B s a = B a - -instance Functor (B s) where - fmap f (B x) = B (f x) - -build :: (forall s . (?builder :: Builder s) => B s a) -> a -build f = - unsafePerformIO $ do - pool <- gu_new_pool - poolFPtr <- newForeignPtr gu_pool_finalizer pool - let ?builder = Builder pool (touchForeignPtr poolFPtr) - let B res = f - return res - -eAbs :: (?builder :: Builder s) => BindType -> String -> B s Expr -> B s Expr -eAbs bind_type var (B (Expr body _)) = - unsafePerformIO $ - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_EXPR_ABS) - (#size PgfExprAbs) - (#const gu_alignof(PgfExprAbs)) - pptr pool - cvar <- newUtf8CString var pool - (#poke PgfExprAbs, bind_type) ptr (cbind_type :: PgfBindType) - (#poke PgfExprAbs, id) ptr cvar - (#poke PgfExprAbs, body) ptr body - e <- peek pptr - return (B (Expr e touch)) - where - (Builder pool touch) = ?builder - - cbind_type = - case bind_type of - Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) - Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) - -eApp :: (?builder :: Builder s) => B s Expr -> B s Expr -> B s Expr -eApp (B (Expr fun _)) (B (Expr arg _)) = - unsafePerformIO $ - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_EXPR_APP) - (#size PgfExprApp) - (#const gu_alignof(PgfExprApp)) - pptr pool - (#poke PgfExprApp, fun) ptr fun - (#poke PgfExprApp, arg) ptr arg - e <- peek pptr - return (B (Expr e touch)) - where - (Builder pool touch) = ?builder - -eMeta :: (?builder :: Builder s) => Int -> B s Expr -eMeta id = - unsafePerformIO $ - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_EXPR_META) - (fromIntegral (#size PgfExprMeta)) - (#const gu_alignof(PgfExprMeta)) - pptr pool - (#poke PgfExprMeta, id) ptr (fromIntegral id :: CInt) - e <- peek pptr - return (B (Expr e touch)) - where - (Builder pool touch) = ?builder - -eFun :: (?builder :: Builder s) => Fun -> B s Expr -eFun fun = - unsafePerformIO $ - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_EXPR_FUN) - (fromIntegral ((#size PgfExprFun)+utf8Length fun)) - (#const gu_flex_alignof(PgfExprFun)) - pptr pool - pokeUtf8CString fun (ptr `plusPtr` (#offset PgfExprFun, fun)) - e <- peek pptr - return (B (Expr e touch)) - where - (Builder pool touch) = ?builder - -eVar :: (?builder :: Builder s) => Int -> B s Expr -eVar var = - unsafePerformIO $ - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_EXPR_VAR) - (#size PgfExprVar) - (#const gu_alignof(PgfExprVar)) - pptr pool - (#poke PgfExprVar, var) ptr (fromIntegral var :: CInt) - e <- peek pptr - return (B (Expr e touch)) - where - (Builder pool touch) = ?builder - -eLit :: (?builder :: Builder s) => Literal -> B s Expr -eLit value = - unsafePerformIO $ - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_EXPR_LIT) - (fromIntegral (#size PgfExprLit)) - (#const gu_alignof(PgfExprLit)) - pptr pool - c_value <- newLiteral value pool - (#poke PgfExprLit, lit) ptr c_value - e <- peek pptr - return (B (Expr e touch)) - where - (Builder pool touch) = ?builder - -eTyped :: (?builder :: Builder s) => B s Expr -> B s Type -> B s Expr -eTyped (B (Expr e _)) (B (Type ty _)) = - unsafePerformIO $ - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_EXPR_TYPED) - (#size PgfExprTyped) - (#const gu_alignof(PgfExprTyped)) - pptr pool - (#poke PgfExprTyped, expr) ptr e - (#poke PgfExprTyped, type) ptr ty - e <- peek pptr - return (B (Expr e touch)) - where - (Builder pool touch) = ?builder - -eImplArg :: (?builder :: Builder s) => B s Expr -> B s Expr -eImplArg (B (Expr e _)) = - unsafePerformIO $ - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_EXPR_IMPL_ARG) - (#size PgfExprImplArg) - (#const gu_alignof(PgfExprImplArg)) - pptr pool - (#poke PgfExprImplArg, expr) ptr e - e <- peek pptr - return (B (Expr e touch)) - where - (Builder pool touch) = ?builder - -hypo :: BindType -> String -> B s Type -> (B s Hypo) -hypo bind_type var (B ty) = B (bind_type,var,ty) - -dTyp :: (?builder :: Builder s) => [B s Hypo] -> Cat -> [B s Expr] -> B s Type -dTyp hypos cat es = - unsafePerformIO $ do - ptr <- gu_malloc_aligned pool - ((#size PgfType)+n_exprs*(#size GuVariant)) - (#const gu_flex_alignof(PgfType)) - c_hypos <- newHypos hypos pool - c_cat <- newUtf8CString cat pool - (#poke PgfType, hypos) ptr c_hypos - (#poke PgfType, cid) ptr c_cat - (#poke PgfType, n_exprs) ptr n_exprs - pokeArray (ptr `plusPtr` (#offset PgfType, exprs)) [e | B (Expr e _) <- es] - return (B (Type ptr touch)) - where - (Builder pool touch) = ?builder - n_exprs = fromIntegral (length es) :: CSizeT - -newHypos :: [B s Hypo] -> Ptr GuPool -> IO (Ptr GuSeq) -newHypos hypos pool = do - c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) pool - pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos - return c_hypos - where - pokeHypos ptr [] = return () - pokeHypos ptr (B (bind_type,var,Type ty _):hypos) = do - c_var <- newUtf8CString var pool - (#poke PgfHypo, bind_type) ptr (cbind_type :: PgfBindType) - (#poke PgfHypo, cid) ptr c_var - (#poke PgfHypo, type) ptr ty - pokeHypos (ptr `plusPtr` (#size PgfHypo)) hypos - where - cbind_type = - case bind_type of - Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) - Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) - - -data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) (Ptr GuBuf) Touch - -newAbstr :: (?builder :: Builder s) => [(String,Literal)] -> - [(Cat,[B s Hypo],Float)] -> - [(Fun,B s Type,Int,[[Instr]],Float)] -> - B s AbstrInfo -newAbstr aflags cats funs = unsafePerformIO $ do - c_aflags <- newFlags aflags pool - (c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool - (c_funs,absfuns) <- newAbsFuns (sortByFst5 funs) pool - c_abs_lin_fun <- newAbsLinFun - c_non_lexical_buf <- gu_make_buf (#size PgfProductionIdxEntry) pool - return (B (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun c_non_lexical_buf touch)) - where - (Builder pool touch) = ?builder - - newAbsCats values pool = do - c_seq <- gu_make_seq (#size PgfAbsCat) (fromIntegral (length values)) pool - abscats <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values - return (c_seq,abscats) - where - pokeElems ptr abscats [] = return abscats - pokeElems ptr abscats (x:xs) = do - abscats <- pokeAbsCat ptr abscats x - pokeElems (ptr `plusPtr` (#size PgfAbsCat)) abscats xs - - pokeAbsCat ptr abscats (name,hypos,prob) = do - c_name <- newUtf8CString name pool - c_hypos <- newHypos hypos pool - (#poke PgfAbsCat, name) ptr c_name - (#poke PgfAbsCat, context) ptr c_hypos - (#poke PgfAbsCat, prob) ptr (realToFrac prob :: CFloat) - return (Map.insert name ptr abscats) - - newAbsFuns values pool = do - c_seq <- gu_make_seq (#size PgfAbsFun) (fromIntegral (length values)) pool - absfuns <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values - return (c_seq,absfuns) - where - pokeElems ptr absfuns [] = return absfuns - pokeElems ptr absfuns (x:xs) = do - absfuns <- pokeAbsFun ptr absfuns x - pokeElems (ptr `plusPtr` (#size PgfAbsFun)) absfuns xs - - pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,_,prob) = do - pfun <- gu_alloc_variant (#const PGF_EXPR_FUN) - (fromIntegral ((#size PgfExprFun)+utf8Length name)) - (#const gu_flex_alignof(PgfExprFun)) - (ptr `plusPtr` (#offset PgfAbsFun, ep.expr)) pool - let c_name = (pfun `plusPtr` (#offset PgfExprFun, fun)) - pokeUtf8CString name c_name - (#poke PgfAbsFun, name) ptr c_name - (#poke PgfAbsFun, type) ptr c_ty - (#poke PgfAbsFun, arity) ptr (fromIntegral arity :: CInt) - (#poke PgfAbsFun, defns) ptr nullPtr - (#poke PgfAbsFun, ep.prob) ptr (realToFrac prob :: CFloat) - return (Map.insert name ptr absfuns) - - newAbsLinFun = do - ptr <- gu_malloc_aligned pool - (#size PgfAbsFun) - (#const gu_alignof(PgfAbsFun)) - c_wild <- newUtf8CString "_" pool - c_ty <- gu_malloc_aligned pool - (#size PgfType) - (#const gu_alignof(PgfType)) - (#poke PgfType, hypos) c_ty nullPtr - (#poke PgfType, cid) c_ty c_wild - (#poke PgfType, n_exprs) c_ty (0 :: CSizeT) - (#poke PgfAbsFun, name) ptr c_wild - (#poke PgfAbsFun, type) ptr c_ty - (#poke PgfAbsFun, arity) ptr (0 :: CSizeT) - (#poke PgfAbsFun, defns) ptr nullPtr - (#poke PgfAbsFun, ep.prob) ptr (- log 0 :: CFloat) - (#poke PgfAbsFun, ep.expr) ptr nullPtr - return ptr - - -data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap) (Ptr PgfConcr -> Ptr GuPool -> IO ()) CInt - -newConcr :: (?builder :: Builder s) => B s AbstrInfo - -> [(String,Literal)] -- ^ Concrete syntax flags - -> [(String,String)] -- ^ Printnames - -> [(FId,[FunId])] -- ^ Lindefs - -> [(FId,[FunId])] -- ^ Linrefs - -> [(FId,[Production])] -- ^ Productions - -> [(Fun,[SeqId])] -- ^ Concrete functions (must be sorted by Fun) - -> [[Symbol]] -- ^ Sequences (must be sorted) - -> [(Cat,FId,FId,[String])] -- ^ Concrete categories - -> FId -- ^ The total count of the categories - -> B s ConcrInfo -newConcr (B (AbstrInfo _ _ abscats _ absfuns c_abs_lin_fun c_non_lexical_buf _)) cflags printnames lindefs linrefs prods cncfuns sequences cnccats total_cats = unsafePerformIO $ do - c_cflags <- newFlags cflags pool - c_printname <- newMap (#size GuString) gu_string_hasher newUtf8CString - (#size GuString) (pokeString pool) - printnames pool - c_seqs <- newSequence (#size PgfSequence) pokeSequence sequences pool - let seqs_ptr = c_seqs `plusPtr` (#offset GuSeq, data) - c_cncfuns <- newSequence (#size PgfCncFun*) (pokeCncFun seqs_ptr) (zip [0..] cncfuns) pool - let funs_ptr = c_cncfuns `plusPtr` (#offset GuSeq, data) - c_ccats <- gu_make_map (#size int) gu_int_hasher - (#size PgfCCat*) gu_null_struct - (#const GU_MAP_DEFAULT_INIT_SIZE) - pool - mapM_ (addLindefs c_ccats funs_ptr) lindefs - mapM_ (addLinrefs c_ccats funs_ptr) linrefs - mk_index <- foldM (addProductions c_ccats funs_ptr c_non_lexical_buf) (\concr pool -> return ()) prods - c_cnccats <- newMap (#size GuString) gu_string_hasher newUtf8CString (#size PgfCncCat*) (pokeCncCat c_ccats) (map (\v@(k,_,_,_) -> (k,v)) cnccats) pool - return (B (ConcrInfo c_cflags c_printname c_ccats c_cncfuns c_seqs c_cnccats mk_index (fromIntegral total_cats))) - where - (Builder pool touch) = ?builder - - pokeCncFun seqs_ptr ptr cncfun@(funid,_) = do - c_cncfun <- newCncFun absfuns seqs_ptr cncfun pool - poke ptr c_cncfun - - pokeSequence c_seq syms = do - c_syms <- newSymbols syms pool - (#poke PgfSequence, syms) c_seq c_syms - (#poke PgfSequence, idx) c_seq nullPtr - - addLindefs c_ccats funs_ptr (fid,funids) = do - c_ccat <- getCCat c_ccats fid pool - c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool - (#poke PgfCCat, lindefs) c_ccat c_funs - - addLinrefs c_ccats funs_ptr (fid,funids) = do - c_ccat <- getCCat c_ccats fid pool - c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool - (#poke PgfCCat, linrefs) c_ccat c_funs - - addProductions c_ccats funs_ptr c_non_lexical_buf mk_index (fid,prods) = do - c_ccat <- getCCat c_ccats fid pool - let n_prods = length prods - c_prods <- gu_make_seq (#size PgfProduction) (fromIntegral n_prods) pool - (#poke PgfCCat, prods) c_ccat c_prods - pokeProductions c_ccat (c_prods `plusPtr` (#offset GuSeq, data)) 0 (n_prods-1) mk_index prods - where - pokeProductions c_ccat ptr top bot mk_index [] = do - (#poke PgfCCat, n_synprods) c_ccat (fromIntegral top :: CSizeT) - return mk_index - pokeProductions c_ccat ptr top bot mk_index (prod:prods) = do - (is_lexical,c_prod) <- newProduction c_ccats funs_ptr c_non_lexical_buf prod pool - let mk_index' = \concr pool -> do pgf_parser_index concr c_ccat c_prod is_lexical pool - pgf_lzr_index concr c_ccat c_prod is_lexical pool - mk_index concr pool - if is_lexical == 0 - then do poke (ptr `plusPtr` ((#size PgfProduction)*top)) c_prod - pokeProductions c_ccat ptr (top+1) bot mk_index' prods - else do poke (ptr `plusPtr` ((#size PgfProduction)*bot)) c_prod - pokeProductions c_ccat ptr top (bot-1) mk_index' prods - - pokeRefDefFunId funs_ptr ptr funid = do - c_fun <- peek (funs_ptr `plusPtr` (funid * (#size PgfCncFun*))) - (#poke PgfCncFun, absfun) c_fun c_abs_lin_fun - poke ptr c_fun - - pokeCncCat c_ccats ptr (name,start,end,labels) = do - let n_lins = fromIntegral (length labels) :: CSizeT - c_cnccat <- gu_malloc_aligned pool - ((#size PgfCncCat)+n_lins*(#size GuString)) - (#const gu_flex_alignof(PgfCncCat)) - case Map.lookup name abscats of - Just c_abscat -> (#poke PgfCncCat, abscat) c_cnccat c_abscat - Nothing -> throwIO (PGFError ("The category "++name++" is not in the abstract syntax")) - c_ccats <- newSequence (#size PgfCCat*) (pokeFId c_cnccat) [start..end] pool - (#poke PgfCncCat, cats) c_cnccat c_ccats - (#poke PgfCncCat, n_lins) c_cnccat n_lins - pokeLabels (c_cnccat `plusPtr` (#offset PgfCncCat, labels)) labels - poke ptr c_cnccat - where - pokeFId c_cnccat ptr fid = do - c_ccat <- getCCat c_ccats fid pool - (#poke PgfCCat, cnccat) c_ccat c_cnccat - poke ptr c_ccat - - pokeLabels ptr [] = return [] - pokeLabels ptr (l:ls) = do - c_l <- newUtf8CString l pool - poke ptr c_l - pokeLabels (ptr `plusPtr` (#size GuString)) ls - - -newPGF :: (?builder :: Builder s) => [(String,Literal)] -> - AbsName -> - B s AbstrInfo -> - [(ConcName,B s ConcrInfo)] -> - B s PGF -newPGF gflags absname (B (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _ _)) concrs = - unsafePerformIO $ do - ptr <- gu_malloc_aligned pool - (#size PgfPGF) - (#const gu_alignof(PgfPGF)) - c_gflags <- newFlags gflags pool - c_absname <- newUtf8CString absname pool - let c_abstr = ptr `plusPtr` (#offset PgfPGF, abstract) - c_concrs <- gu_make_seq (#size PgfConcr) (fromIntegral (length concrs)) pool - langs <- pokeConcrs c_abstr (c_concrs `plusPtr` (#offset GuSeq, data)) Map.empty concrs - (#poke PgfPGF, major_version) ptr (2 :: (#type uint16_t)) - (#poke PgfPGF, minor_version) ptr (0 :: (#type uint16_t)) - (#poke PgfPGF, gflags) ptr c_gflags - (#poke PgfPGF, abstract.name) ptr c_absname - (#poke PgfPGF, abstract.aflags) ptr c_aflags - (#poke PgfPGF, abstract.funs) ptr c_funs - (#poke PgfPGF, abstract.cats) ptr c_cats - (#poke PgfPGF, abstract.abs_lin_fun) ptr c_abs_lin_fun - (#poke PgfPGF, concretes) ptr c_concrs - (#poke PgfPGF, pool) ptr pool - return (B (PGF ptr langs touch)) - where - (Builder pool touch) = ?builder - - pokeConcrs c_abstr ptr langs [] = return langs - pokeConcrs c_abstr ptr langs ((name, B info):xs) = do - pokeConcr c_abstr ptr name info - pokeConcrs c_abstr (ptr `plusPtr` (fromIntegral (#size PgfConcr))) - (Map.insert name (Concr ptr touch) langs) - xs - - pokeConcr c_abstr ptr name (ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats mk_index c_total_cats) = do - c_name <- newUtf8CString name pool - c_fun_indices <- gu_make_map (#size GuString) gu_string_hasher - (#size PgfCncOverloadMap*) gu_null_struct - (#const GU_MAP_DEFAULT_INIT_SIZE) - pool - c_coerce_idx <- gu_make_map (#size PgfCCat*) gu_addr_hasher - (#size GuBuf*) gu_null_struct - (#const GU_MAP_DEFAULT_INIT_SIZE) - pool - (#poke PgfConcr, name) ptr c_name - (#poke PgfConcr, abstr) ptr c_abstr - (#poke PgfConcr, cflags) ptr c_cflags - (#poke PgfConcr, printnames) ptr c_printnames - (#poke PgfConcr, ccats) ptr c_ccats - (#poke PgfConcr, fun_indices) ptr c_fun_indices - (#poke PgfConcr, coerce_idx) ptr c_coerce_idx - (#poke PgfConcr, cncfuns) ptr c_cncfuns - (#poke PgfConcr, sequences) ptr c_seqs - (#poke PgfConcr, cnccats) ptr c_cnccats - (#poke PgfConcr, total_cats) ptr c_total_cats - (#poke PgfConcr, pool) ptr nullPtr - - mk_index ptr pool - pgf_concrete_fix_internals ptr - - -newFlags :: [(String,Literal)] -> Ptr GuPool -> IO (Ptr GuSeq) -newFlags flags pool = newSequence (#size PgfFlag) pokeFlag (sortByFst flags) pool - where - pokeFlag c_flag (name,value) = do - c_name <- newUtf8CString name pool - c_value <- newLiteral value pool - (#poke PgfFlag, name) c_flag c_name - (#poke PgfFlag, value) c_flag c_value - - -newLiteral :: Literal -> Ptr GuPool -> IO GuVariant -newLiteral (LStr val) pool = - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_LITERAL_STR) - (fromIntegral ((#size PgfLiteralStr)+utf8Length val)) - (#const gu_flex_alignof(PgfLiteralStr)) - pptr pool - pokeUtf8CString val (ptr `plusPtr` (#offset PgfLiteralStr, val)) - peek pptr -newLiteral (LInt val) pool = - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_LITERAL_INT) - (fromIntegral (#size PgfLiteralInt)) - (#const gu_alignof(PgfLiteralInt)) - pptr pool - (#poke PgfLiteralInt, val) ptr (fromIntegral val :: CInt) - peek pptr -newLiteral (LFlt val) pool = - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_LITERAL_FLT) - (fromIntegral (#size PgfLiteralFlt)) - (#const gu_alignof(PgfLiteralFlt)) - pptr pool - (#poke PgfLiteralFlt, val) ptr (realToFrac val :: CDouble) - peek pptr - - -newProduction :: Ptr GuMap -> Ptr PgfCncFun -> Ptr GuBuf -> Production -> Ptr GuPool -> IO ((#type bool), GuVariant) -newProduction c_ccats funs_ptr c_non_lexical_buf (PApply funid args) pool = - alloca $ \pptr -> do - c_fun <- peek (funs_ptr `plusPtr` (funid * (#size PgfCncFun*))) - c_args <- newSequence (#size PgfPArg) pokePArg args pool - ptr <- gu_alloc_variant (#const PGF_PRODUCTION_APPLY) - (fromIntegral (#size PgfProductionApply)) - (#const gu_alignof(PgfProductionApply)) - pptr pool - (#poke PgfProductionApply, fun) ptr (c_fun :: Ptr PgfCncFun) - (#poke PgfProductionApply, args) ptr c_args - is_lexical <- pgf_production_is_lexical ptr c_non_lexical_buf pool - c_prod <- peek pptr - return (is_lexical,c_prod) - where - pokePArg ptr (PArg hypos ccat) = do - c_ccat <- getCCat c_ccats ccat pool - (#poke PgfPArg, ccat) ptr c_ccat - c_hypos <- newSequence (#size PgfCCat*) pokeCCat (map snd hypos) pool - (#poke PgfPArg, hypos) ptr c_hypos - - pokeCCat ptr ccat = do - c_ccat <- getCCat c_ccats ccat pool - poke ptr c_ccat - -newProduction c_ccats funs_ptr c_non_lexical_buf (PCoerce fid) pool = - alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_PRODUCTION_COERCE) - (fromIntegral (#size PgfProductionCoerce)) - (#const gu_alignof(PgfProductionCoerce)) - pptr pool - c_ccat <- getCCat c_ccats fid pool - (#poke PgfProductionCoerce, coerce) ptr c_ccat - c_prod <- peek pptr - return (0,c_prod) - - -newCncFun absfuns seqs_ptr (funid,(fun,seqids)) pool = - do let c_absfun = fromMaybe nullPtr (Map.lookup fun absfuns) - c_ep = if c_absfun == nullPtr - then nullPtr - else c_absfun `plusPtr` (#offset PgfAbsFun, ep) - n_lins = fromIntegral (length seqids) :: CSizeT - ptr <- gu_malloc_aligned pool - ((#size PgfCncFun)+n_lins*(#size PgfSequence*)) - (#const gu_flex_alignof(PgfCncFun)) - (#poke PgfCncFun, absfun) ptr c_absfun - (#poke PgfCncFun, ep) ptr c_ep - (#poke PgfCncFun, funid) ptr (funid :: CInt) - (#poke PgfCncFun, n_lins) ptr n_lins - pokeSequences seqs_ptr (ptr `plusPtr` (#offset PgfCncFun, lins)) seqids - return ptr - where - pokeSequences seqs_ptr ptr [] = return () - pokeSequences seqs_ptr ptr (seqid:seqids) = do - poke ptr (seqs_ptr `plusPtr` (seqid * (#size PgfSequence))) - pokeSequences seqs_ptr (ptr `plusPtr` (#size PgfSequence*)) seqids - -getCCat c_ccats fid pool = - alloca $ \pfid -> do - poke pfid (fromIntegral fid :: CInt) - ptr <- gu_map_find_default c_ccats pfid - c_ccat <- peek ptr - if c_ccat /= nullPtr - then return c_ccat - else do c_ccat <- gu_malloc_aligned pool - (#size PgfCCat) - (#const gu_alignof(PgfCCat)) - (#poke PgfCCat, cnccat) c_ccat nullPtr - (#poke PgfCCat, lindefs) c_ccat nullPtr - (#poke PgfCCat, linrefs) c_ccat nullPtr - (#poke PgfCCat, n_synprods) c_ccat (0 :: CSizeT) - (#poke PgfCCat, prods) c_ccat nullPtr - (#poke PgfCCat, viterbi_prob) c_ccat (0 :: CFloat) - (#poke PgfCCat, fid) c_ccat fid - (#poke PgfCCat, conts) c_ccat nullPtr - (#poke PgfCCat, answers) c_ccat nullPtr - ptr <- gu_map_insert c_ccats pfid - poke ptr c_ccat - return c_ccat - -newSymbol :: Symbol -> Ptr GuPool -> IO GuVariant -newSymbol (SymCat d r) pool = alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAT) - (fromIntegral (#size PgfSymbolCat)) - (#const gu_alignof(PgfSymbolCat)) - pptr pool - (#poke PgfSymbolCat, d) ptr (fromIntegral d :: CInt) - (#poke PgfSymbolCat, r) ptr (fromIntegral r :: CInt) - peek pptr -newSymbol (SymLit d r) pool = alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_SYMBOL_LIT) - (fromIntegral (#size PgfSymbolLit)) - (#const gu_alignof(PgfSymbolLit)) - pptr pool - (#poke PgfSymbolLit, d) ptr (fromIntegral d :: CInt) - (#poke PgfSymbolLit, r) ptr (fromIntegral r :: CInt) - peek pptr -newSymbol (SymVar d r) pool = alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_SYMBOL_VAR) - (fromIntegral (#size PgfSymbolVar)) - (#const gu_alignof(PgfSymbolVar)) - pptr pool - (#poke PgfSymbolVar, d) ptr (fromIntegral d :: CInt) - (#poke PgfSymbolVar, r) ptr (fromIntegral r :: CInt) - peek pptr -newSymbol (SymKS t) pool = alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_SYMBOL_KS) - (fromIntegral ((#size PgfSymbolKS)+utf8Length t)) - (#const gu_flex_alignof(PgfSymbolKS)) - pptr pool - pokeUtf8CString t (ptr `plusPtr` (#offset PgfSymbolKS, token)) - peek pptr -newSymbol (SymKP def alts) pool = alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_SYMBOL_KP) - (fromIntegral ((#size PgfSymbolKP)+(length alts * (#size PgfAlternative)))) - (#const gu_flex_alignof(PgfSymbolKP)) - pptr pool - c_def <- newSymbols def pool - (#poke PgfSymbolKP, default_form) ptr c_def - pokeAlternatives (ptr `plusPtr` (#offset PgfSymbolKP, forms)) alts pool - peek pptr -newSymbol SymBIND pool = alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_SYMBOL_BIND) - (fromIntegral (#size PgfSymbolBIND)) - (#const gu_alignof(PgfSymbolBIND)) - pptr pool - peek pptr -newSymbol SymNE pool = alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_SYMBOL_NE) - (fromIntegral (#size PgfSymbolNE)) - (#const gu_alignof(PgfSymbolNE)) - pptr pool - peek pptr -newSymbol SymSOFT_BIND pool = alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_BIND) - (fromIntegral (#size PgfSymbolBIND)) - (#const gu_alignof(PgfSymbolBIND)) - pptr pool - peek pptr -newSymbol SymSOFT_SPACE pool = alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_SPACE) - (fromIntegral (#size PgfSymbolBIND)) - (#const gu_alignof(PgfSymbolBIND)) - pptr pool - peek pptr -newSymbol SymCAPIT pool = alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAPIT) - (fromIntegral (#size PgfSymbolCAPIT)) - (#const gu_alignof(PgfSymbolCAPIT)) - pptr pool - peek pptr -newSymbol SymALL_CAPIT pool = alloca $ \pptr -> do - ptr <- gu_alloc_variant (#const PGF_SYMBOL_ALL_CAPIT) - (fromIntegral (#size PgfSymbolCAPIT)) - (#const gu_alignof(PgfSymbolCAPIT)) - pptr pool - peek pptr - -newSymbols syms pool = newSequence (#size PgfSymbol) pokeSymbol syms pool - where - pokeSymbol p_sym sym = do - c_sym <- newSymbol sym pool - poke p_sym c_sym - -pokeAlternatives ptr [] pool = return () -pokeAlternatives ptr ((syms,prefixes):alts) pool = do - c_syms <- newSymbols syms pool - c_prefixes <- newSequence (#size GuString) (pokeString pool) prefixes pool - (#poke PgfAlternative, form) ptr c_syms - (#poke PgfAlternative, prefixes) ptr c_prefixes - pokeAlternatives (ptr `plusPtr` (#size PgfAlternative)) alts pool - -pokeString pool c_elem str = do - c_str <- newUtf8CString str pool - poke c_elem c_str - -newMap key_size hasher newKey elem_size pokeElem values pool = do - map <- gu_make_map key_size hasher - elem_size gu_null_struct - (#const GU_MAP_DEFAULT_INIT_SIZE) - pool - insert map values pool - return map - where - insert map [] pool = return () - insert map ((key,elem):values) pool = do - c_key <- newKey key pool - c_elem <- gu_map_insert map c_key - pokeElem c_elem elem - insert map values pool - - -unionPGF :: PGF -> PGF -> Maybe PGF -unionPGF one@(PGF ptr1 langs1 touch1) two@(PGF ptr2 langs2 touch2) - | pgf_have_same_abstract ptr1 ptr2 /= 0 = Just (PGF ptr1 (Map.union langs1 langs2) (touch1 >> touch2)) - | otherwise = Nothing - -writePGF :: FilePath -> PGF -> IO () -writePGF fpath p = do - pool <- gu_new_pool - exn <- gu_new_exn pool - withArrayLen ((map concr . Map.elems . languages) p) $ \n_concrs concrs -> - withCString fpath $ \c_fpath -> - pgf_write (pgf p) (fromIntegral n_concrs) concrs c_fpath exn - touchPGF p - 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 - gu_pool_free pool - ioError (errnoToIOError "writePGF" (Errno errno) Nothing (Just fpath)) - else do gu_pool_free pool - throwIO (PGFError "The grammar cannot be stored") - else do gu_pool_free pool - return () - -writeConcr :: FilePath -> Concr -> IO () -writeConcr fpath c = do - pool <- gu_new_pool - exn <- gu_new_exn pool - withCString fpath $ \c_fpath -> - pgf_concrete_save (concr c) c_fpath exn - touchConcr c - 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 - gu_pool_free pool - ioError (errnoToIOError "writeConcr" (Errno errno) Nothing (Just fpath)) - else do gu_pool_free pool - throwIO (PGFError "The grammar cannot be stored") - else do gu_pool_free pool - return () - -sortByFst = sortBy (\(x,_) (y,_) -> compare x y) -sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y) -sortByFst5 = sortBy (\(x,_,_,_,_) (y,_,_,_,_) -> compare x y) diff --git a/src/runtime/haskell/PGF2/Type.hsc b/src/runtime/haskell/PGF2/Type.hsc index f39246183..dafad8e9c 100644 --- a/src/runtime/haskell/PGF2/Type.hsc +++ b/src/runtime/haskell/PGF2/Type.hsc @@ -1,148 +1,3 @@ #include module PGF2.Type where - -import System.IO.Unsafe(unsafePerformIO) -import Foreign hiding (unsafePerformIO) -import Foreign.C -import qualified Text.PrettyPrint as PP -import Data.List(mapAccumL) -import PGF2.Expr -import PGF2.FFI - --- The C structure for the expression may point to other structures --- which are allocated from other pools. In order to ensure that --- they are not released prematurely we use the exprMaster to --- store references to other Haskell objects -data Type = Type {typ :: PgfExpr, touchType :: Touch} - --- | 'Hypo' represents a hypothesis in a type i.e. in the type A -> B, A is the hypothesis -type Hypo = (BindType,String,Type) - -instance Show Type where - show = showType [] - -instance Eq Type where - (Type ty1 ty1_touch) == (Type ty2 ty2_touch) = - unsafePerformIO $ do - res <- pgf_type_eq ty1 ty2 - ty1_touch >> ty2_touch - return (res /= 0) - --- | parses a 'String' as a type -readType :: String -> Maybe Type -readType str = - unsafePerformIO $ - do typPl <- gu_new_pool - withGuPool $ \tmpPl -> - do c_str <- newUtf8CString str tmpPl - guin <- gu_string_in c_str tmpPl - exn <- gu_new_exn tmpPl - c_type <- pgf_read_type guin typPl tmpPl exn - status <- gu_exn_is_raised exn - if (not status && c_type /= nullPtr) - then do typFPl <- newForeignPtr gu_pool_finalizer typPl - return $ Just (Type c_type (touchForeignPtr typFPl)) - else do gu_pool_free typPl - return Nothing - --- | renders a type as a 'String'. The list --- of identifiers is the list of all free variables --- in the type in order reverse to the order --- of binding. -showType :: [String] -> Type -> String -showType scope (Type ty touch) = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - printCtxt <- newPrintCtxt scope tmpPl - exn <- gu_new_exn tmpPl - pgf_print_type ty printCtxt 0 out exn - touch - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s - --- | creates a type from a list of hypothesises, a category and --- a list of arguments for the category. The operation --- @mkType [h_1,...,h_n] C [e_1,...,e_m]@ will create --- @h_1 -> ... -> h_n -> C e_1 ... e_m@ -mkType :: [Hypo] -> String -> [Expr] -> Type -mkType hypos cat exprs = unsafePerformIO $ do - typPl <- gu_new_pool - let n_exprs = fromIntegral (length exprs) :: CSizeT - c_type <- gu_malloc typPl ((#size PgfType) + n_exprs * (#size PgfExpr)) - c_hypos <- newSequence (#size PgfHypo) (pokeHypo typPl) hypos typPl - (#poke PgfType, hypos) c_type c_hypos - ccat <- newUtf8CString cat typPl - (#poke PgfType, cid) c_type ccat - (#poke PgfType, n_exprs) c_type n_exprs - pokeExprs (c_type `plusPtr` (#offset PgfType, exprs)) exprs - typFPl <- newForeignPtr gu_pool_finalizer typPl - return (Type c_type (mapM_ touchHypo hypos >> mapM_ touchExpr exprs >> touchForeignPtr typFPl)) - -pokeHypo :: Ptr GuPool -> Ptr a -> Hypo -> IO () -pokeHypo pool c_hypo (bind_type,cid,Type c_ty _) = do - (#poke PgfHypo, bind_type) c_hypo cbind_type - newUtf8CString cid pool >>= (#poke PgfHypo, cid) c_hypo - (#poke PgfHypo, type) c_hypo c_ty - where - cbind_type :: CInt - cbind_type = - case bind_type of - Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) - Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) - -pokeExprs ptr [] = return () -pokeExprs ptr ((Expr e _):es) = do - poke ptr e - pokeExprs (plusPtr ptr (#size PgfExpr)) es - -touchHypo (_,_,ty) = touchType ty - --- | Decomposes a type into a list of hypothesises, a category and --- a list of arguments for the category. -unType :: Type -> ([Hypo],String,[Expr]) -unType (Type c_type touch) = unsafePerformIO $ do - cid <- (#peek PgfType, cid) c_type >>= peekUtf8CString - c_hypos <- (#peek PgfType, hypos) c_type - n_hypos <- (#peek GuSeq, len) c_hypos - hs <- peekHypos (c_hypos `plusPtr` (#offset GuSeq, data)) 0 n_hypos - n_exprs <- (#peek PgfType, n_exprs) c_type - es <- peekExprs (c_type `plusPtr` (#offset PgfType, exprs)) 0 n_exprs - return (hs,cid,es) - where - peekHypos :: Ptr a -> Int -> Int -> IO [Hypo] - peekHypos c_hypo i n - | i < n = do cid <- (#peek PgfHypo, cid) c_hypo >>= peekUtf8CString - c_ty <- (#peek PgfHypo, type) c_hypo - bt <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo) - hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n - return ((bt,cid,Type c_ty touch) : hs) - | otherwise = return [] - - toBindType :: CInt -> BindType - toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit - toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit - - peekExprs ptr i n - | i < n = do e <- peekElemOff ptr i - es <- peekExprs ptr (i+1) n - return (Expr e touch : es) - | otherwise = return [] - --- | renders a type as a 'String'. The list --- of identifiers is the list of all free variables --- in the type in order reverse to the order --- of binding. -showContext :: [String] -> [Hypo] -> String -showContext scope hypos = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl - printCtxt <- newPrintCtxt scope tmpPl - exn <- gu_new_exn tmpPl - pgf_print_context c_hypos printCtxt out exn - mapM_ touchHypo hypos - s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s diff --git a/src/runtime/haskell/pgf2.cabal b/src/runtime/haskell/pgf2.cabal index d5af1223d..db7babb2f 100644 --- a/src/runtime/haskell/pgf2.cabal +++ b/src/runtime/haskell/pgf2.cabal @@ -23,7 +23,7 @@ library default-language: Haskell2010 build-tools: hsc2hs - extra-libraries: sg pgf gu + extra-libraries: pgf cc-options: -std=c99 default-language: Haskell2010 c-sources: utils.c