From 2ae4468738f740f5946549dc9ab97512d862c2d4 Mon Sep 17 00:00:00 2001 From: krasimir Date: Wed, 2 Sep 2015 07:12:36 +0000 Subject: [PATCH] added the minimal Haskell API for storing expressions/triples in the semantic graph --- src/runtime/haskell-bind/PGF2.hsc | 135 +--------------------- src/runtime/haskell-bind/PGF2/Expr.hsc | 138 +++++++++++++++++++++++ src/runtime/haskell-bind/PGF2/FFI.hs | 5 + src/runtime/haskell-bind/SG.hsc | 133 ++++++++++++++++++++++ src/runtime/haskell-bind/SG/FFI.hs | 39 +++++++ src/runtime/haskell-bind/pgf2-bind.cabal | 8 +- 6 files changed, 321 insertions(+), 137 deletions(-) create mode 100644 src/runtime/haskell-bind/PGF2/Expr.hsc create mode 100644 src/runtime/haskell-bind/SG.hsc create mode 100644 src/runtime/haskell-bind/SG/FFI.hs diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index c1416bed8..40002ff50 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -38,6 +38,7 @@ import Prelude hiding (fromEnum) import Control.Exception(Exception,throwIO) import Control.Monad(forM_) import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO) +import PGF2.Expr import PGF2.FFI import Foreign hiding ( Pool, newPool, unsafePerformIO ) @@ -48,13 +49,7 @@ import Data.IORef import Data.Char(isUpper,isSpace) import Data.List(isSuffixOf,maximumBy,nub) import Data.Function(on) -import qualified Text.PrettyPrint as PP ---import Debug.Trace -type CId = String - -ppCId = PP.text -wildCId = "_" :: CId ----------------------------------------------------------------------- -- Functions that take a PGF. @@ -69,8 +64,6 @@ data Concr = Concr {concr :: Ptr PgfConcr, concrMaster :: PGF} type AbsName = String -- ^ Name of abstract syntax type ConcName = String -- ^ Name of concrete syntax -type Cat = String -- ^ Name of syntactic category -type Fun = String -- ^ Name of function readPGF :: FilePath -> IO PGF readPGF fpath = @@ -151,46 +144,6 @@ loadConcr c fpath = unloadConcr :: Concr -> IO () unloadConcr c = pgf_concrete_unload (concr c) ------------------------------------------------------------------------------ --- Types - -data Type = - DTyp [Hypo] CId [Expr] - deriving Show - -data BindType = - Explicit - | Implicit - deriving Show - --- | 'Hypo' represents a hypothesis in a type i.e. in the type A -> B, A is the hypothesis -type Hypo = (BindType,CId,Type) - --- | renders type as 'String'. -showType :: Type -> String -showType = PP.render . ppType 0 - -ppType :: Int -> Type -> PP.Doc -ppType d (DTyp hyps cat args) - | null hyps = ppRes cat args - | otherwise = let hdocs = map (ppHypo 1) hyps - in ppParens (d > 0) (foldr (\hdoc doc -> hdoc PP.<+> PP.text "->" PP.<+> doc) (ppRes cat args) hdocs) - where - ppRes cat es - | null es = ppCId cat - | otherwise = ppParens (d > 3) (ppCId cat PP.<+> PP.hsep (map (ppExpr 4) es)) - -ppHypo :: Int -> (BindType,CId,Type) -> PP.Doc -ppHypo d (Explicit,x,typ) = - if x == wildCId - then ppType d typ - else PP.parens (ppCId x PP.<+> PP.char ':' PP.<+> ppType 0 typ) -ppHypo d (Implicit,x,typ) = - PP.parens (PP.braces (ppCId x) PP.<+> PP.char ':' PP.<+> ppType 0 typ) - -ppParens True = PP.parens -ppParens False = id - functionType :: PGF -> CId -> Type functionType p fn = unsafePerformIO $ @@ -228,85 +181,7 @@ functionType p fn = ----------------------------------------------------------------------------- --- 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 = forall a . Expr {expr :: PgfExpr, exprMaster :: a} - -instance Show Expr where - show = showExpr - -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 (exprFPl,args)) - where - len = length args - -unApp :: Expr -> Maybe (Fun,[Expr]) -unApp (Expr expr master) = - 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 master | c_arg <- c_args]) - -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 exprFPl) - -readExpr :: String -> Maybe Expr -readExpr str = - unsafePerformIO $ - do exprPl <- gu_new_pool - withGuPool $ \tmpPl -> - withCString str $ \c_str -> - do guin <- gu_string_in c_str tmpPl - exn <- gu_new_exn tmpPl - c_expr <- pgf_read_expr guin exprPl exn - status <- gu_exn_is_raised exn - if (not status && c_expr /= nullPtr) - then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl - return $ Just (Expr c_expr exprFPl) - else do gu_pool_free exprPl - return Nothing - -ppExpr :: Int -> Expr -> PP.Doc -ppExpr d e = ppParens (d>0) (PP.text (showExpr e)) -- just a quick hack !!! - -showExpr :: Expr -> String -showExpr e = - unsafePerformIO $ - withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - let printCtxt = nullPtr - exn <- gu_new_exn tmpPl - pgf_print_expr (expr e) printCtxt 1 out exn - s <- gu_string_buf_freeze sb tmpPl - peekCString s - +-- Graphviz graphvizAbstractTree :: PGF -> Expr -> String graphvizAbstractTree p e = @@ -589,12 +464,6 @@ categoryContext pgf cat = Nothing -- !!! not implemented yet TODO ----------------------------------------------------------------------------- -- Helper functions -newOut :: Ptr GuPool -> IO (Ptr GuStringBuf, Ptr GuOut) -newOut pool = - do sb <- gu_string_buf pool - out <- gu_string_buf_out sb - return (sb,out) - fromPgfExprEnum :: Ptr GuEnum -> ForeignPtr GuPool -> a -> IO [(Expr, Float)] fromPgfExprEnum enum fpl master = do pgfExprProb <- alloca $ \ptr -> diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc new file mode 100644 index 000000000..6dc7dd161 --- /dev/null +++ b/src/runtime/haskell-bind/PGF2/Expr.hsc @@ -0,0 +1,138 @@ +{-# LANGUAGE ExistentialQuantification #-} +#include + +module PGF2.Expr where + +import Foreign +import Foreign.C +import qualified Text.PrettyPrint as PP +import PGF2.FFI + +type CId = String + +ppCId = PP.text +wildCId = "_" :: CId + +type Cat = String -- ^ Name of syntactic category +type Fun = String -- ^ Name of function + +----------------------------------------------------------------------------- +-- 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 = forall a . Expr {expr :: PgfExpr, exprMaster :: a} + +instance Show Expr where + show = showExpr + +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 (exprFPl,args)) + where + len = length args + +unApp :: Expr -> Maybe (Fun,[Expr]) +unApp (Expr expr master) = + 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 master | c_arg <- c_args]) + +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 exprFPl) + +readExpr :: String -> Maybe Expr +readExpr str = + unsafePerformIO $ + do exprPl <- gu_new_pool + withGuPool $ \tmpPl -> + withCString str $ \c_str -> + do guin <- gu_string_in c_str tmpPl + exn <- gu_new_exn tmpPl + c_expr <- pgf_read_expr guin exprPl exn + status <- gu_exn_is_raised exn + if (not status && c_expr /= nullPtr) + then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl + return $ Just (Expr c_expr exprFPl) + else do gu_pool_free exprPl + return Nothing + +ppExpr :: Int -> Expr -> PP.Doc +ppExpr d e = ppParens (d>0) (PP.text (showExpr e)) -- just a quick hack !!! + +showExpr :: Expr -> String +showExpr e = + unsafePerformIO $ + withGuPool $ \tmpPl -> + do (sb,out) <- newOut tmpPl + let printCtxt = nullPtr + exn <- gu_new_exn tmpPl + pgf_print_expr (expr e) printCtxt 1 out exn + s <- gu_string_buf_freeze sb tmpPl + peekCString s + + +----------------------------------------------------------------------------- +-- Types + +data Type = + DTyp [Hypo] CId [Expr] + deriving Show + +data BindType = + Explicit + | Implicit + deriving Show + +-- | 'Hypo' represents a hypothesis in a type i.e. in the type A -> B, A is the hypothesis +type Hypo = (BindType,CId,Type) + +-- | renders type as 'String'. +showType :: Type -> String +showType = PP.render . ppType 0 + +ppType :: Int -> Type -> PP.Doc +ppType d (DTyp hyps cat args) + | null hyps = ppRes cat args + | otherwise = let hdocs = map (ppHypo 1) hyps + in ppParens (d > 0) (foldr (\hdoc doc -> hdoc PP.<+> PP.text "->" PP.<+> doc) (ppRes cat args) hdocs) + where + ppRes cat es + | null es = ppCId cat + | otherwise = ppParens (d > 3) (ppCId cat PP.<+> PP.hsep (map (ppExpr 4) es)) + +ppHypo :: Int -> (BindType,CId,Type) -> PP.Doc +ppHypo d (Explicit,x,typ) = + if x == wildCId + then ppType d typ + else PP.parens (ppCId x PP.<+> PP.char ':' PP.<+> ppType 0 typ) +ppHypo d (Implicit,x,typ) = + PP.parens (PP.braces (ppCId x) PP.<+> PP.char ':' PP.<+> ppType 0 typ) + +ppParens True = PP.parens +ppParens False = id diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index 295c1fde9..96b3eea35 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -76,6 +76,11 @@ foreign import ccall "gu/string.h gu_string_buf_freeze" 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_string_buf pool + out <- gu_string_buf_out sb + return (sb,out) ------------------------------------------------------------------ -- libpgf API diff --git a/src/runtime/haskell-bind/SG.hsc b/src/runtime/haskell-bind/SG.hsc new file mode 100644 index 000000000..300cec27a --- /dev/null +++ b/src/runtime/haskell-bind/SG.hsc @@ -0,0 +1,133 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +#include +#include +#include + +module SG( SG, openSG, closeSG + , beginTrans, commit, rollback, inTransaction + , SgId + , insertExpr + , insertTriple + ) where + +import Foreign +import Foreign.C +import SG.FFI +import PGF2.FFI +import PGF2.Expr + +import Data.Typeable +import Control.Exception(Exception,SomeException,catch,throwIO) + +----------------------------------------------------------------------- +-- Global database operations and types + +newtype SG = SG {sg :: Ptr SgSG} + +openSG :: FilePath -> IO SG +openSG fpath = + withCString fpath $ \c_fpath -> + withGuPool $ \tmpPl -> do + exn <- gu_new_exn tmpPl + sg <- sg_open c_fpath exn + failed <- gu_exn_is_raised exn + if failed + then do is_errno <- gu_exn_caught exn gu_exn_type_GuErrno + if is_errno + then do perrno <- (#peek GuExn, data.data) exn + errno <- peek perrno + ioError (errnoToIOError "openSG" (Errno errno) Nothing (Just fpath)) + else do is_sgerr <- gu_exn_caught exn gu_exn_type_SgError + if is_sgerr + then do c_msg <- (#peek GuExn, data.data) exn + msg <- peekCString c_msg + throwIO (SGError msg) + else throwIO (SGError "The database cannot be opened") + else return (SG sg) + +closeSG :: SG -> IO () +closeSG (SG sg) = + withGuPool $ \tmpPl -> do + exn <- gu_new_exn tmpPl + sg <- sg_close sg exn + handle_sg_exn exn + +beginTrans :: SG -> IO () +beginTrans (SG sg) = + withGuPool $ \tmpPl -> do + exn <- gu_new_exn tmpPl + sg <- sg_begin_trans sg exn + handle_sg_exn exn + +commit :: SG -> IO () +commit (SG sg) = + withGuPool $ \tmpPl -> do + exn <- gu_new_exn tmpPl + sg <- sg_commit sg exn + handle_sg_exn exn + +rollback :: SG -> IO () +rollback (SG sg) = + withGuPool $ \tmpPl -> do + exn <- gu_new_exn tmpPl + sg <- sg_rollback sg exn + handle_sg_exn exn + +inTransaction :: SG -> IO a -> IO a +inTransaction sg f = + catch (beginTrans sg >> f >>= \x -> commit sg >> return x) + (\e -> rollback sg >> throwIO (e :: SomeException)) + +----------------------------------------------------------------------- +-- Expressions + +insertExpr :: SG -> Expr -> IO SgId +insertExpr (SG sg) (Expr expr _) = + withGuPool $ \tmpPl -> do + exn <- gu_new_exn tmpPl + id <- sg_insert_expr sg expr exn + handle_sg_exn exn + return id + +----------------------------------------------------------------------- +-- Triples + +insertTriple :: SG -> Expr -> Expr -> Expr -> IO SgId +insertTriple (SG sg) (Expr expr1 _) (Expr expr2 _) (Expr expr3 _) = + withGuPool $ \tmpPl -> + withTriple $ \triple -> do + exn <- gu_new_exn tmpPl + id1 <- sg_insert_expr sg expr1 exn + handle_sg_exn exn + pokeElemOff triple 0 id1 + id2 <- sg_insert_expr sg expr2 exn + handle_sg_exn exn + pokeElemOff triple 1 id2 + id3 <- sg_insert_expr sg expr3 exn + handle_sg_exn exn + pokeElemOff triple 2 id3 + id <- sg_insert_triple sg triple exn + handle_sg_exn exn + return id + +----------------------------------------------------------------------- +-- Exceptions + +newtype SGError = SGError String + deriving (Show, Typeable) + +instance Exception SGError + +handle_sg_exn exn = do + failed <- gu_exn_is_raised exn + if failed + then do is_sgerr <- gu_exn_caught exn gu_exn_type_SgError + if is_sgerr + then do c_msg <- (#peek GuExn, data.data) exn + msg <- peekCString c_msg + throwIO (SGError msg) + else throwIO (SGError "Unknown database error") + else return () + +----------------------------------------------------------------------- diff --git a/src/runtime/haskell-bind/SG/FFI.hs b/src/runtime/haskell-bind/SG/FFI.hs new file mode 100644 index 000000000..2874082bb --- /dev/null +++ b/src/runtime/haskell-bind/SG/FFI.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ForeignFunctionInterface, MagicHash #-} +module SG.FFI where + +import Foreign +import Foreign.C +import PGF2.FFI +import GHC.Ptr +import Data.Int + +data SgSG +type SgId = Int64 + +foreign import ccall "sg/sg.h sg_open" + sg_open :: CString -> Ptr GuExn -> IO (Ptr SgSG) + +foreign import ccall "sg/sg.h sg_close" + sg_close :: Ptr SgSG -> Ptr GuExn -> IO () + +foreign import ccall "sg/sg.h sg_begin_trans" + sg_begin_trans :: Ptr SgSG -> Ptr GuExn -> IO () + +foreign import ccall "sg/sg.h sg_commit" + sg_commit :: Ptr SgSG -> Ptr GuExn -> IO () + +foreign import ccall "sg/sg.h sg_rollback" + sg_rollback :: Ptr SgSG -> Ptr GuExn -> IO () + +foreign import ccall "sg/sg.h sg_insert_expr" + sg_insert_expr :: Ptr SgSG -> PgfExpr -> Ptr GuExn -> IO SgId + +foreign import ccall "sg/sg.h sg_insert_triple" + sg_insert_triple :: Ptr SgSG -> SgTriple -> Ptr GuExn -> IO SgId + +type SgTriple = Ptr SgId + +withTriple :: (SgTriple -> IO a) -> IO a +withTriple = allocaArray 3 + +gu_exn_type_SgError = Ptr "SgError"# :: CString diff --git a/src/runtime/haskell-bind/pgf2-bind.cabal b/src/runtime/haskell-bind/pgf2-bind.cabal index 29b41254e..4e60264a5 100644 --- a/src/runtime/haskell-bind/pgf2-bind.cabal +++ b/src/runtime/haskell-bind/pgf2-bind.cabal @@ -17,15 +17,15 @@ extra-source-files: README cabal-version: >=1.10 library - exposed-modules: PGF2 - other-modules: PGF2.FFI + exposed-modules: PGF2, SG + other-modules: PGF2.FFI, PGF2.Expr, SG.FFI build-depends: base >=4.3, bytestring >=0.9, - containers + containers, pretty -- hs-source-dirs: default-language: Haskell2010 build-tools: hsc2hs - extra-libraries: pgf gu + extra-libraries: sg pgf gu cc-options: -std=c99 default-language: Haskell2010 c-sources: utils.c