first rudimentary version of a parser

src/runtime/haskell/PGF2.hsc

@@ -97,7 +97,7 @@ import Foreign
 import Foreign.C
 import Control.Monad(forM,forM_)
 import Control.Exception(bracket,mask_,throwIO)
-import System.IO.Unsafe(unsafePerformIO)
+import System.IO.Unsafe(unsafePerformIO, unsafeInterleaveIO)
 import System.Random
 import qualified Data.Map as Map
 import Data.IORef
@@ -673,7 +673,30 @@ data ParseOutput a
   | ParseIncomplete                -- ^ The sentence is not complete.
 
 parse :: Concr -> Type -> String -> ParseOutput [(Expr,Float)]
-parse lang ty sent = parseWithHeuristics lang ty sent (-1.0) []
+parse c ty sent =
+  unsafePerformIO $
+  withForeignPtr (c_revision c) $ \c_revision ->
+  withForeignPtr marshaller $ \m ->
+  bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
+  withText sent $ \c_sent -> do
+    c_enum <- withPgfExn "parse" (pgf_parse (c_db c) c_revision c_ty m c_sent)
+    c_fetch <- (#peek PgfExprEnumVtbl, fetch) =<< (#peek PgfExprEnum, vtbl) c_enum
+    exprs <- unsafeInterleaveIO (fetchLazy c_fetch c_enum)
+    return (ParseOk exprs)
+  where
+    fetchLazy c_fetch c_enum =
+      withForeignPtr (c_revision c) $ \c_revision ->
+      withForeignPtr unmarshaller $ \u -> 
+      alloca $ \p_prob -> do
+        c_expr <- callFetch c_fetch c_enum (c_db c) u p_prob
+        if c_expr == castPtrToStablePtr nullPtr
+          then do pgf_free_expr_enum c_enum
+                  return []
+          else do expr <- deRefStablePtr c_expr
+                  freeStablePtr c_expr
+                  prob <- peek p_prob
+                  rest <- unsafeInterleaveIO (fetchLazy c_fetch c_enum)
+                  return ((expr,prob) : rest)
 
 parseWithHeuristics :: Concr      -- ^ the language with which we parse
                     -> Type       -- ^ the start category

src/runtime/haskell/PGF2/FFI.hsc

@@ -50,6 +50,7 @@ data PgfProbsCallback
 data PgfMorphoCallback
 data PgfCohortsCallback
 data PgfPhrasetableIds
+data PgfExprEnum
 
 type Wrapper a = a -> IO (FunPtr a)
 type Dynamic a = FunPtr a -> a
@@ -253,6 +254,12 @@ foreign import ccall pgf_bracketed_linearize :: Ptr PgfDB -> Ptr Concr -> Stable
 
 foreign import ccall pgf_bracketed_linearize_all :: Ptr PgfDB -> Ptr Concr -> StablePtr Expr -> Ptr PgfPrintContext -> Ptr PgfMarshaller -> Ptr PgfLinearizationOutputIface -> Ptr PgfExn -> IO ()
 
+foreign import ccall pgf_parse :: Ptr PgfDB -> Ptr Concr -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PgfExprEnum)
+
+foreign import ccall "dynamic" callFetch :: Dynamic (Ptr PgfExprEnum -> Ptr PgfDB -> Ptr PgfUnmarshaller -> Ptr (#type prob_t) -> IO (StablePtr Expr))
+
+foreign import ccall pgf_free_expr_enum :: Ptr PgfExprEnum -> IO ()
+
 foreign import ccall "wrapper" wrapSymbol0 :: Wrapper (Ptr PgfLinearizationOutputIface -> IO ())
 
 foreign import ccall "wrapper" wrapSymbol1 :: Wrapper (Ptr PgfLinearizationOutputIface -> Ptr PgfText -> IO ())

src/runtime/haskell/tests/basic.pmcfg

@@ -18,42 +18,42 @@ concrete basic_cnc {
   lincat Float = [
            "s"
          ]
-  lindef Float :  String(0) -> Float(0) = [S0]
-  linref Float : Float(0) -> String(0) = [S0]
+  lindef Float(0) -> Float[String(0)] = [S0]
+  linref String(0) -> Float[Float(0)] = [S0]
   lincat Int = [
            "s"
          ]
-  lindef Int :  String(0) -> Int(0) = [S0]
-  linref Int : Int(0) -> String(0) = [S0]
+  lindef Int(0) -> Int[String(0)] = [S0]
+  linref String(0) -> Int[Int(0)] = [S0]
   lincat N = [
            "s"
          ]
-  lindef N :  String(0) -> N(0) = [S0]
-  linref N : ∀{i<2} . N(i) -> String(0) = [S0]
+  lindef N(0) -> N[String(0)] = [S0]
+  linref ∀{i<2} . String(0) -> N[N(i)] = [S0]
   lincat P = [
            "s"
          ]
-  lindef P :  String(0) -> P(0) = [S0]
-  linref P : P(0) -> String(0) = [S0]
+  lindef P(0) -> P[String(0)] = [S0]
+  linref String(0) -> P[P(0)] = [S0]
   lincat S = [
            ""
          ]
-  lindef S :  String(0) -> S(0) = [S0]
-  linref S : S(0) -> String(0) = [S0]
+  lindef S(0) -> S[String(0)] = [S0]
+  linref String(0) -> S[S(0)] = [S0]
   lincat String = [
            "s"
          ]
-  lindef String :  String(0) -> String(0) = [S0]
-  linref String : String(0) -> String(0) = [S0]
-  lin c : ∀{i<2} . N(i) -> S(0) = [S0]
-  lin floatLit : Float(0) -> S(0) = [S0]
-  lin ind : ∀{i<2} . P(0) * P(0) * N(i) -> P(0) = [S1]
-  lin intLit : Int(0) -> S(0) = [S0]
-  lin nat : ∀{i<2} . N(i) -> P(0) = [S5]
-  lin s : N(0) -> N(0) = [S2]
-  lin s : N(1) -> N(0) = [S4]
-  lin stringLit : String(0) -> S(0) = [S0]
-  lin z : N(1) = [S3]
+  lindef String(0) -> String[String(0)] = [S0]
+  linref String(0) -> String[String(0)] = [S0]
+  lin ∀{i<2} . S(0) -> c[N(i)] = [S0]
+  lin S(0) -> floatLit[Float(0)] = [S0]
+  lin ∀{i<2} . P(0) -> ind[P(0),P(0),N(i)] = [S1]
+  lin S(0) -> intLit[Int(0)] = [S0]
+  lin ∀{i<2} . P(0) -> nat[N(i)] = [S5]
+  lin N(0) -> s[N(0)] = [S2]
+  lin N(0) -> s[N(1)] = [S4]
+  lin S(0) -> stringLit[String(0)] = [S0]
+  lin N(1) -> z[] = [S3]
   sequences {
     S0 = <0,0>
     S1 = <0,0> "&" "λ" SOFT_BIND <1,$0> SOFT_BIND "," SOFT_BIND <1,$1> "." <1,0>