bring the Haskell binding a bit closer to the pure Haskell API

4 files changed, 55 insertions, 121 deletions

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index 5d0484c1e..a368d9ccd 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -38,7 +38,9 @@ module PGF2 (-- * PGF
              mkFloat,unFloat,
              mkMeta,unMeta,
              -- ** Types
-             Type(..), Hypo, BindType(..), startCat, showType,
+             Type, Hypo, BindType(..), startCat,
+             readType, showType,
+             mkType, unType,
 
              -- * Concrete syntax
              ConcName,Concr,languages,
@@ -69,6 +71,7 @@ import Control.Monad(forM_)
 import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO)
 import Text.PrettyPrint
 import PGF2.Expr
+import PGF2.Type
 import PGF2.FFI
 
 import Foreign hiding ( Pool, newPool, unsafePerformIO )
@@ -141,13 +144,12 @@ languages p =
 -- all abstract syntax expressions of the given type. 
 -- The expressions are ordered by their probability.
 generateAll :: PGF -> Type -> [(Expr,Float)]
-generateAll p (DTyp _ cat _) =
+generateAll p (Type ctype _) =
   unsafePerformIO $
     do genPl  <- gu_new_pool
        exprPl <- gu_new_pool
-       cat    <- newUtf8CString cat genPl
        exn    <- gu_new_exn genPl
-       enum   <- pgf_generate_all (pgf p) cat exn genPl exprPl
+       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 (p,exprFPl)
@@ -164,9 +166,9 @@ abstractName p = unsafePerformIO (peekUtf8CString =<< pgf_abstract_name (pgf p))
 -- definition is just for convenience.
 startCat :: PGF -> Type
 startCat p = unsafePerformIO $ do
-  cat <- pgf_start_cat (pgf p)
-  cat <- peekUtf8CString cat
-  return (DTyp [] cat [])
+  typPl <- gu_new_pool
+  c_type <- pgf_start_cat (pgf p) typPl
+  return (Type c_type typPl)
 
 loadConcr :: Concr -> FilePath -> IO ()
 loadConcr c fpath =
@@ -199,36 +201,7 @@ functionType p fn =
     c_type <- pgf_function_type (pgf p) c_fn
     if c_type == nullPtr
       then throwIO (PGFError ("Function '"++fn++"' is not defined"))
-      else peekType c_type
-  where
-    peekType c_type = 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 (DTyp hs cid es)
-
-    peekHypos :: Ptr a -> Int -> Int -> IO [Hypo]
-    peekHypos c_hypo i n
-      | i < n     = do cid <- (#peek PgfHypo, cid) c_hypo >>= peekUtf8CString
-                       ty  <- (#peek PgfHypo, type) c_hypo >>= peekType
-                       bt  <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo)
-                       hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n
-                       return ((bt,cid,ty) : 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 p : es)
-      | otherwise = return []
-
+      else return (Type c_type (pgfMaster p))
 
 -----------------------------------------------------------------------------
 -- Graphviz
@@ -326,15 +299,14 @@ parseWithHeuristics :: Concr      -- ^ the language with which we parse
                                   -- If a literal has been recognized then the output should
                                   -- be Just (expr,probability,end_offset)
                     -> Either String [(Expr,Float)]
-parseWithHeuristics lang (DTyp _ cat _) sent heuristic callbacks =
+parseWithHeuristics lang (Type ctype _) sent heuristic callbacks =
   unsafePerformIO $
     do exprPl  <- gu_new_pool
        parsePl <- gu_new_pool
        exn     <- gu_new_exn parsePl
-       cat     <- newUtf8CString cat  parsePl
        sent    <- newUtf8CString sent parsePl
        callbacks_map <- mkCallbacksMap (concr lang) callbacks parsePl
-       enum    <- pgf_parse_with_heuristics (concr lang) cat sent heuristic callbacks_map exn parsePl exprPl
+       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
@@ -574,7 +546,7 @@ showBracketedString :: BracketedString -> String
 showBracketedString = render . ppBracketedString
 
 ppBracketedString (Leaf t) = text t
-ppBracketedString (Bracket cat fid index _ bss) = parens (ppCId cat <> colon <> int fid <+> hsep (map ppBracketedString bss))
+ppBracketedString (Bracket cat fid index _ bss) = parens (text cat <> colon <> int fid <+> hsep (map ppBracketedString bss))
 
 -- | Extracts the sequence of tokens from the bracketed string
 flattenBracketedString :: BracketedString -> [String]
@@ -657,7 +629,7 @@ functionsByCat p cat =
 -- with the \'cat\' keyword.
 categories :: PGF -> [Cat]
 categories pgf = -- !!! quick hack
-    nub [cat | f<-functions pgf, let DTyp _ cat _=functionType pgf f]
+    nub [cat | f<-functions pgf, let (_, cat, _) = unType (functionType pgf f)]
 
 categoryContext :: PGF -> Cat -> Maybe [Hypo]
 categoryContext pgf cat = Nothing -- !!! not implemented yet TODO
@@ -729,7 +701,7 @@ nerc pgf (lang,concr) sentence lin_idx offset =
         Just (y,xs') -> (y:ys,xs'')
           where (ys,xs'') = consume munch xs'
 
-    functionCat f = case functionType pgf f of DTyp _ cat _ -> cat
+    functionCat f = case unType (functionType pgf f) of (_,cat,_) -> cat
 
 -- | Callback to parse arbitrary words as chunks (from
 -- ../java/org/grammaticalframework/pgf/UnknownLiteralCallback.java)
diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc
index c18e97a13..84559e5a0 100644
--- a/src/runtime/haskell-bind/PGF2/Expr.hsc
+++ b/src/runtime/haskell-bind/PGF2/Expr.hsc
@@ -6,20 +6,22 @@ module PGF2.Expr where
 import System.IO.Unsafe(unsafePerformIO)
 import Foreign hiding (unsafePerformIO)
 import Foreign.C
-import qualified Text.PrettyPrint as PP
 import PGF2.FFI
-import Data.List(mapAccumL)
 
 -- | An data type that represents
 -- identifiers for functions and categories in PGF.
 type CId = String
 
-ppCId = PP.text
 wildCId = "_" :: CId
 
 type Cat = CId -- ^ Name of syntactic category
 type Fun = CId -- ^ Name of function
 
+data BindType = 
+    Explicit
+  | Implicit
+  deriving Show
+
 -----------------------------------------------------------------------------
 -- Expressions
 
@@ -177,19 +179,16 @@ 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 -> [CId] -> Expr -> PP.Doc
-ppExpr d xs e = ppParens (d>0) (PP.text (showExpr xs e)) -- just a quick hack !!!
+         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 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
 
 -- | renders an expression as a 'String'. The list
 -- of identifiers is the list of all free variables
@@ -200,62 +199,16 @@ showExpr scope e =
   unsafePerformIO $
     withGuPool $ \tmpPl ->
       do (sb,out) <- newOut tmpPl
-         let printCtxt = nullPtr
+         printCtxt <- newPrintCtxt scope tmpPl
          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 -> [CId] -> Type -> PP.Doc
-ppType d scope (DTyp hyps cat args)
-  | null hyps = ppRes scope cat args
-  | otherwise = let (scope',hdocs) = mapAccumL (ppHypo 1) scope hyps
-                in ppParens (d > 0) (foldr (\hdoc doc -> hdoc PP.<+> PP.text "->" PP.<+> doc) (ppRes scope cat args) hdocs)
-  where
-    ppRes scope cat es
-      | null es   = ppCId cat
-      | otherwise = ppParens (d > 3) (ppCId cat PP.<+> PP.hsep (map (ppExpr 4 scope) es))
-
-ppHypo :: Int -> [CId]-> (BindType,CId,Type) -> ([CId],PP.Doc)
-ppHypo d scope (Explicit,x,typ) =
-    if x == wildCId
-    then (scope, ppType d scope typ)
-    else let y = freshName x scope
-         in (y:scope, PP.parens (ppCId x PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
-ppHypo d scope (Implicit,x,typ) =
-    if x == wildCId
-    then (scope,PP.parens (PP.braces (ppCId x) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
-    else let y = freshName x scope
-         in (y:scope,PP.parens (PP.braces (ppCId x) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
-
-freshName :: CId -> [CId] -> CId
-freshName x xs0 = loop 1 x
-  where
-    xs = wildCId : xs0
-
-    loop i y
-      | elem y xs = loop (i+1) (x++show i)
-      | otherwise = y
-
-ppParens True  = PP.parens
-ppParens False = id
+         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-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs
index 9051b1465..949c46471 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hs
+++ b/src/runtime/haskell-bind/PGF2/FFI.hs
@@ -85,6 +85,9 @@ foreign import ccall unsafe "gu/utf8.h gu_utf8_decode"
 foreign import ccall unsafe "gu/utf8.h gu_utf8_encode"
   gu_utf8_encode :: Int32 -> Ptr CString -> IO ()
 
+foreign import ccall unsafe "gu/seq.h gu_make_seq"
+  gu_make_seq :: CInt -> CInt -> Ptr GuPool -> IO (Ptr GuSeq)
+
 withGuPool :: (Ptr GuPool -> IO a) -> IO a
 withGuPool f = bracket gu_new_pool gu_pool_free f
 
@@ -133,7 +136,7 @@ data PgfExprProb
 data PgfFullFormEntry
 data PgfMorphoCallback
 data PgfPrintContext
-data PgfType
+type PgfType = Ptr ()
 data PgfCallbacksMap
 data PgfOracleCallback
 data PgfCncTree
@@ -166,7 +169,7 @@ 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_start_cat"
-  pgf_start_cat :: Ptr PgfPGF -> IO CString
+  pgf_start_cat :: Ptr PgfPGF -> Ptr GuPool -> IO PgfType
 
 foreign import ccall "pgf/pgf.h pgf_iter_functions"
   pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
@@ -175,7 +178,7 @@ 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 (Ptr PgfType)
+   pgf_function_type :: Ptr PgfPGF -> CString -> IO PgfType
 
 foreign import ccall "pgf/pgf.h pgf_print_name"
   pgf_print_name :: Ptr PgfConcr -> CString -> IO CString
@@ -199,7 +202,7 @@ 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_with_heuristics"
-  pgf_parse_with_heuristics :: Ptr PgfConcr -> CString -> CString -> Double -> Ptr PgfCallbacksMap -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
+  pgf_parse_with_heuristics :: Ptr PgfConcr -> PgfType -> CString -> Double -> Ptr PgfCallbacksMap -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
 
 type LiteralMatchCallback = CInt -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb)
 
@@ -293,8 +296,11 @@ foreign import ccall "pgf/expr.h pgf_print_expr"
 foreign import ccall "pgf/expr.h pgf_print_expr_tuple"
   pgf_print_expr_tuple :: CInt -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO ()
 
+foreign import ccall "pgf/expr.h pgf_print_type"
+  pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
+
 foreign import ccall "pgf/pgf.h pgf_generate_all"
-  pgf_generate_all :: Ptr PgfPGF -> CString -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
+  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 -> Ptr GuOut -> Ptr GuExn -> IO ()
@@ -308,6 +314,9 @@ foreign import ccall "pgf/expr.h pgf_read_expr_tuple"
 foreign import ccall "pgf/expr.h pgf_read_expr_matrix"
   pgf_read_expr_matrix :: Ptr GuIn -> CInt -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq)
 
+foreign import ccall "pgf/expr.h pgf_read_type"
+  pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfType
+
 foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree"
   pgf_graphviz_abstract_tree :: Ptr PgfPGF -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO ()
 
diff --git a/src/runtime/haskell-bind/pgf2-bind.cabal b/src/runtime/haskell-bind/pgf2-bind.cabal
index 4e60264a5..dfde308b9 100644
--- a/src/runtime/haskell-bind/pgf2-bind.cabal
+++ b/src/runtime/haskell-bind/pgf2-bind.cabal
@@ -18,7 +18,7 @@ cabal-version:       >=1.10
 
 library
   exposed-modules:     PGF2, SG
-  other-modules:       PGF2.FFI, PGF2.Expr, SG.FFI
+  other-modules:       PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI
   build-depends:       base >=4.3, bytestring >=0.9,
                        containers, pretty
   -- hs-source-dirs: