added the minimal Haskell API for storing expressions/triples in the semantic graph

6 files changed, 321 insertions, 137 deletions

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 <pgf/pgf.h>
+
+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 <pgf/pgf.h>
+#include <gu/exn.h>
+#include <sg/sg.h>
+
+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