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

2 files changed, 39 insertions, 77 deletions

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 ()