handle productions in the internal creation API

src/runtime/haskell-bind/PGF2/FFI.hsc

@@ -38,6 +38,7 @@ data GuMap
 data GuMapItor
 data GuHasher
 data GuSeq
+data GuBuf
 data GuPool
 type GuVariant = Ptr ()
 type GuHash = (#type GuHash)
@@ -112,6 +113,9 @@ foreign import ccall unsafe "gu/utf8.h gu_utf8_encode"
 foreign import ccall unsafe "gu/seq.h gu_make_seq"
   gu_make_seq :: CSizeT -> CSizeT -> Ptr GuPool -> IO (Ptr GuSeq)
 
+foreign import ccall unsafe "gu/seq.h gu_make_buf"
+  gu_make_buf :: CSizeT -> Ptr GuPool -> IO (Ptr GuBuf)
+
 foreign import ccall unsafe "gu/map.h gu_make_map"
   gu_make_map :: CSizeT -> Ptr GuHasher -> CSizeT -> Ptr a -> CSizeT -> Ptr GuPool -> IO (Ptr GuMap)
 
@@ -127,6 +131,9 @@ foreign import ccall "gu/map.h gu_map_iter"
 foreign import ccall unsafe "gu/hash.h &gu_int_hasher"
   gu_int_hasher :: Ptr GuHasher
 
+foreign import ccall unsafe "gu/hash.h &gu_addr_hasher"
+  gu_addr_hasher :: Ptr GuHasher
+
 foreign import ccall unsafe "gu/hash.h &gu_string_hasher"
   gu_string_hasher :: Ptr GuHasher
 
@@ -227,6 +234,9 @@ data PgfGraphvizOptions
 type PgfBindType = (#type PgfBindType)
 data PgfAbsFun
 data PgfAbsCat
+data PgfCCat
+data PgfCncFun
+data PgfProductionApply
 
 foreign import ccall "pgf/pgf.h pgf_read"
   pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF)
@@ -471,3 +481,12 @@ foreign import ccall "pgf/graphviz.h pgf_graphviz_parse_tree"
 
 foreign import ccall "pgf/graphviz.h pgf_graphviz_word_alignment"
   pgf_graphviz_word_alignment :: Ptr (Ptr PgfConcr) -> CSizeT -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()
+
+foreign import ccall "pgf/data.h pgf_parser_index"
+  pgf_parser_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO ()
+
+foreign import ccall "pgf/data.h pgf_lzr_index"
+  pgf_lzr_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO ()
+
+foreign import ccall "pgf/data.h pgf_production_is_lexical"
+  pgf_production_is_lexical :: Ptr PgfProductionApply -> Ptr GuBuf -> Ptr GuPool -> IO (#type bool)

src/runtime/haskell-bind/PGF2/Internal.hsc

@@ -29,6 +29,7 @@ import Data.IORef
 import Data.Maybe(fromMaybe)
 import Data.List(sortBy)
 import Control.Exception(Exception,throwIO)
+import Control.Monad(foldM)
 import qualified Data.Map as Map
 
 type Token = String
@@ -454,7 +455,7 @@ newHypos hypos pool = do
             Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
 
 
-data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) Touch
+data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) (Ptr GuBuf) Touch
 
 newAbstr :: (?builder :: Builder s) => [(String,Literal)] ->
                                        [(Cat,[B s Hypo],Float)] ->
@@ -465,7 +466,8 @@ newAbstr aflags cats funs = unsafePerformIO $ do
   (c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool
   (c_funs,absfuns) <- newAbsFuns (sortByFst4 funs) pool
   c_abs_lin_fun <- newAbsLinFun
-  return (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun touch)
+  c_non_lexical_buf <- gu_make_buf (#size PgfProductionIdxEntry) pool
+  return (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun c_non_lexical_buf touch)
   where
     (Builder pool touch) = ?builder
 
@@ -531,7 +533,7 @@ newAbstr aflags cats funs = unsafePerformIO $ do
       return ptr
 
 
-data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap)
+data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap) (Ptr PgfConcr -> Ptr GuPool -> IO ()) CInt
 
 newConcr :: (?builder :: Builder s) => AbstrInfo ->
                                        [(String,Literal)] ->       -- ^ Concrete syntax flags
@@ -542,8 +544,9 @@ newConcr :: (?builder :: Builder s) => AbstrInfo ->
                                        [(Fun,[SeqId])] ->          -- ^ Concrete functions   (must be sorted by Fun)
                                        [[Symbol]] ->               -- ^ Sequences            (must be sorted)
                                        [(Cat,FId,FId,[String])] -> -- ^ Concrete categories
+                                       FId ->                      -- ^ The total count of the categories
                                        ConcrInfo
-newConcr (AbstrInfo _ _ abscats  _ absfuns c_abs_lin_fun _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats = unsafePerformIO $ do
+newConcr (AbstrInfo _ _ abscats  _ absfuns c_abs_lin_fun c_non_lexical_buf _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats total_cats = unsafePerformIO $ do
   c_cflags <- newFlags cflags pool
   c_printname <- newMap (#size GuString) gu_string_hasher newUtf8CString 
                         (#size GuString) (pokeString pool)
@@ -558,9 +561,9 @@ newConcr (AbstrInfo _ _ abscats  _ absfuns c_abs_lin_fun _) cflags printnames li
                          pool
   mapM_ (addLindefs c_ccats funs_ptr) lindefs
   mapM_ (addLinrefs c_ccats funs_ptr) linrefs
-  mapM_ (addProductions c_ccats funs_ptr) prods
+  mk_index <- foldM (addProductions c_ccats funs_ptr c_non_lexical_buf) (\concr pool -> return ()) prods
   c_cnccats <- newMap (#size GuString) gu_string_hasher newUtf8CString (#size PgfCncCat*) (pokeCncCat c_ccats) (map (\v@(k,_,_,_) -> (k,v)) cnccats) pool
-  return (ConcrInfo c_cflags c_printname c_ccats c_cncfuns c_seqs c_cnccats)
+  return (ConcrInfo c_cflags c_printname c_ccats c_cncfuns c_seqs c_cnccats mk_index (fromIntegral total_cats))
   where
     (Builder pool touch) = ?builder
 
@@ -575,20 +578,34 @@ newConcr (AbstrInfo _ _ abscats  _ absfuns c_abs_lin_fun _) cflags printnames li
 
     addLindefs c_ccats funs_ptr (fid,funids) = do
       c_ccat <- getCCat c_ccats fid pool
-      c_funs <- newSequence (#size PgfCncFun*) (pokeFunId funs_ptr) funids pool
+      c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool
       (#poke PgfCCat, lindefs) c_ccat c_funs
 
     addLinrefs c_ccats funs_ptr (fid,funids) = do
       c_ccat <- getCCat c_ccats fid pool
-      c_funs <- newSequence (#size PgfCncFun*) (pokeFunId funs_ptr) funids pool
+      c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool
       (#poke PgfCCat, linrefs) c_ccat c_funs
 
-    addProductions c_ccats funs_ptr (fid,prods) = do
+    addProductions c_ccats funs_ptr c_non_lexical_buf mk_index (fid,prods) = do
       c_ccat <- getCCat c_ccats fid pool
-      c_prods <- gu_make_seq (#size PgfProduction) (fromIntegral (length prods)) pool
+      let n_prods = length prods
+      c_prods <- gu_make_seq (#size PgfProduction) (fromIntegral n_prods) pool
       (#poke PgfCCat, prods) c_ccat c_prods
+      pokeProductions c_ccat (c_prods `plusPtr` (#offset GuSeq, data)) 0 (n_prods-1) mk_index prods
+      where
+        pokeProductions c_ccat ptr top bot mk_index []           = return mk_index
+        pokeProductions c_ccat ptr top bot mk_index (prod:prods) = do
+          (is_lexical,c_prod) <- newProduction c_ccats funs_ptr c_non_lexical_buf prod pool
+          let mk_index' = \concr pool -> do pgf_parser_index concr c_ccat c_prod is_lexical pool
+                                            pgf_lzr_index    concr c_ccat c_prod is_lexical pool
+                                            mk_index concr pool
+          if is_lexical == 0
+            then do poke (ptr `plusPtr` ((#size PgfProduction)*top)) c_prod
+                    pokeProductions c_ccat ptr (top+1) bot mk_index' prods
+            else do poke (ptr `plusPtr` ((#size PgfProduction)*bot)) c_prod
+                    pokeProductions c_ccat ptr top (bot-1) mk_index' prods
 
-    pokeFunId funs_ptr ptr funid = do
+    pokeRefDefFunId funs_ptr ptr funid = do
       let c_fun = funs_ptr `plusPtr` (funid * (#size PgfCncFun))
       (#poke PgfCncFun, absfun) c_fun c_abs_lin_fun
       poke ptr c_fun
@@ -622,7 +639,7 @@ newPGF :: (?builder :: Builder s) => [(String,Literal)] ->
                                      AbstrInfo ->
                                      [(ConcName,ConcrInfo)] ->
                                      B s PGF
-newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _) concrs =
+newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _ _) concrs =
   unsafePerformIO $ do
     ptr <- gu_malloc_aligned pool
                              (#size PgfPGF)
@@ -645,17 +662,29 @@ newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _) con
   where
     (Builder pool touch) = ?builder
 
-    pokeConcr c_abstr ptr (name, ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats) = do
+    pokeConcr c_abstr ptr (name, ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats mk_index c_total_cats) = do
       c_name <- newUtf8CString name pool
+      c_fun_indices <- gu_make_map (#size GuString) gu_string_hasher
+                                   (#size PgfCncOverloadMap*) gu_null_struct
+                                   (#const GU_MAP_DEFAULT_INIT_SIZE)
+                                   pool
+      c_coerce_idx  <- gu_make_map (#size PgfCCat*) gu_addr_hasher
+                                   (#size GuBuf*) gu_null_struct
+                                   (#const GU_MAP_DEFAULT_INIT_SIZE)
+                                   pool
       (#poke PgfConcr, name)        ptr c_name
       (#poke PgfConcr, abstr)       ptr c_abstr
       (#poke PgfConcr, cflags)      ptr c_cflags
       (#poke PgfConcr, printnames)  ptr c_printnames
       (#poke PgfConcr, ccats)       ptr c_ccats
+      (#poke PgfConcr, fun_indices) ptr c_fun_indices
+      (#poke PgfConcr, coerce_idx)  ptr c_coerce_idx
       (#poke PgfConcr, cncfuns)     ptr c_cncfuns
       (#poke PgfConcr, sequences)   ptr c_seqs
       (#poke PgfConcr, cnccats)     ptr c_cnccats
+      (#poke PgfConcr, total_cats)  ptr c_total_cats
       (#poke PgfConcr, pool)        ptr nullPtr
+      mk_index ptr pool
 
 
 newFlags :: [(String,Literal)] -> Ptr GuPool -> IO (Ptr GuSeq)
@@ -667,6 +696,7 @@ newFlags flags pool = newSequence (#size PgfFlag) pokeFlag (sortByFst flags) poo
       (#poke PgfFlag, name)  c_flag c_name
       (#poke PgfFlag, value) c_flag c_value
 
+
 newLiteral :: Literal -> Ptr GuPool -> IO GuVariant
 newLiteral (LStr val) pool =
   alloca $ \pptr -> do
@@ -693,6 +723,44 @@ newLiteral (LFlt val) pool =
     (#poke PgfLiteralFlt, val) ptr (realToFrac val :: CDouble)
     peek pptr
 
+
+newProduction :: Ptr GuMap -> Ptr PgfCncFun -> Ptr GuBuf -> Production -> Ptr GuPool -> IO ((#type bool), GuVariant)
+newProduction c_ccats funs_ptr c_non_lexical_buf (PApply fun_id args) pool =
+  alloca $ \pptr -> do
+    let c_fun = funs_ptr `plusPtr` (fun_id * (#size PgfCncFun))
+    c_args <- newSequence (#size PgfPArg) pokePArg args pool
+    ptr <- gu_alloc_variant (#const PGF_PRODUCTION_APPLY)
+                            (fromIntegral (#size PgfProductionApply))
+                            (#const gu_alignof(PgfProductionApply))
+                            pptr pool
+    (#poke PgfProductionApply, fun)  ptr c_fun
+    (#poke PgfProductionApply, args) ptr c_args
+    is_lexical <- pgf_production_is_lexical ptr c_non_lexical_buf pool
+    c_prod <- peek pptr
+    return (is_lexical,c_prod)
+  where
+    pokePArg ptr (PArg hypos ccat) = do
+      c_ccat <- getCCat c_ccats ccat pool
+      (#poke PgfPArg, ccat) ptr c_ccat
+      c_hypos <- newSequence (#size PgfCCat*) pokeCCat hypos pool
+      (#poke PgfPArg, hypos) ptr c_hypos
+
+    pokeCCat ptr ccat = do
+      c_ccat <- getCCat c_ccats ccat pool
+      poke ptr c_ccat
+
+newProduction c_ccats funs_ptr c_non_lexical_buf (PCoerce fid) pool =
+  alloca $ \pptr -> do
+    ptr <- gu_alloc_variant (#const PGF_PRODUCTION_COERCE)
+                            (fromIntegral (#size PgfProductionCoerce))
+                            (#const gu_alignof(PgfProductionCoerce))
+                            pptr pool
+    c_ccat <- getCCat c_ccats fid pool
+    (#poke PgfProductionCoerce, coerce) ptr c_ccat
+    c_prod <- peek pptr
+    return (0,c_prod)
+
+
 newCncFun absfuns seqs_ptr (funid,(fun,seqids)) pool =
   do let c_absfun = fromMaybe nullPtr (Map.lookup fun absfuns)
          c_ep     = if c_absfun == nullPtr