an almost complete API for building new PGF files in the Haskell binding

2 files changed, 361 insertions, 45 deletions

diff --git a/src/runtime/haskell-bind/PGF2/FFI.hsc b/src/runtime/haskell-bind/PGF2/FFI.hsc
index 9de864fcc..e6846b66a 100644
--- a/src/runtime/haskell-bind/PGF2/FFI.hsc
+++ b/src/runtime/haskell-bind/PGF2/FFI.hsc
@@ -29,13 +29,14 @@ data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch}
 data GuEnum
 data GuExn
 data GuIn
+data GuOut
 data GuKind
 data GuType
 data GuString
 data GuStringBuf
 data GuMap
 data GuMapItor
-data GuOut
+data GuHasher
 data GuSeq
 data GuPool
 type GuVariant = Ptr ()
@@ -111,12 +112,27 @@ 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/map.h gu_make_map"
+  gu_make_map :: CSizeT -> Ptr GuHasher -> CSizeT -> Ptr a -> CSizeT -> Ptr GuPool -> IO (Ptr GuMap)
+
+foreign import ccall unsafe "gu/map.h gu_map_insert"
+  gu_map_insert :: Ptr GuMap -> Ptr a -> IO (Ptr b)
+
 foreign import ccall unsafe "gu/map.h gu_map_find_default"
   gu_map_find_default :: Ptr GuMap -> Ptr a -> IO (Ptr b)
 
 foreign import ccall "gu/map.h gu_map_iter"
   gu_map_iter :: Ptr GuMap -> Ptr GuMapItor -> Ptr GuExn -> IO ()
 
+foreign import ccall unsafe "gu/hash.h &gu_int_hasher"
+  gu_int_hasher :: Ptr GuHasher
+
+foreign import ccall unsafe "gu/hash.h &gu_string_hasher"
+  gu_string_hasher :: Ptr GuHasher
+
+foreign import ccall unsafe "gu/hash.h &gu_null_struct"
+  gu_null_struct :: Ptr a
+
 foreign import ccall unsafe "gu/variant.h gu_variant_tag"
   gu_variant_tag :: GuVariant -> IO CInt
 
@@ -209,6 +225,8 @@ data PgfCncTree
 data PgfLinFuncs
 data PgfGraphvizOptions
 type PgfBindType = (#type PgfBindType)
+data PgfAbsFun
+data PgfAbsCat
 
 foreign import ccall "pgf/pgf.h pgf_read"
   pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF)
diff --git a/src/runtime/haskell-bind/PGF2/Internal.hsc b/src/runtime/haskell-bind/PGF2/Internal.hsc
index d24b94bc4..b74a01001 100644
--- a/src/runtime/haskell-bind/PGF2/Internal.hsc
+++ b/src/runtime/haskell-bind/PGF2/Internal.hsc
@@ -10,7 +10,7 @@ module PGF2.Internal(-- * Access the internal structures
                      
                      -- * Building new PGFs in memory
                      build, eAbs, eApp, eMeta, eFun, eVar, eTyped, eImplArg, dTyp, hypo,
-                     newAbstr, newPGF,
+                     AbstrInfo, newAbstr, ConcrInfo, newConcr, newPGF,
                      
                      -- * Write an in-memory PGF to a file
                      writePGF
@@ -26,8 +26,10 @@ import System.IO.Unsafe(unsafePerformIO)
 import Foreign
 import Foreign.C
 import Data.IORef
-import qualified Data.Map as Map
+import Data.Maybe(fromMaybe)
+import Data.List(sortBy)
 import Control.Exception(Exception,throwIO)
+import qualified Data.Map as Map
 
 type Token = String
 data Symbol
@@ -61,32 +63,31 @@ data Literal =
 -- Access the internal structures
 -----------------------------------------------------------------------
 
-globalFlags :: PGF -> Map.Map String Literal
+globalFlags :: PGF -> [(String,Literal)]
 globalFlags p = unsafePerformIO $ do
   c_flags <- (#peek PgfPGF, gflags) (pgf p)
   flags   <- peekFlags c_flags
   touchPGF p
   return flags
 
-abstrFlags :: PGF -> Map.Map String Literal
+abstrFlags :: PGF -> [(String,Literal)]
 abstrFlags p = unsafePerformIO $ do
   c_flags <- (#peek PgfPGF, abstract.aflags) (pgf p)
   flags   <- peekFlags c_flags
   touchPGF p
   return flags
 
-concrFlags :: Concr -> Map.Map String Literal
+concrFlags :: Concr -> [(String,Literal)]
 concrFlags c = unsafePerformIO $ do
   c_flags <- (#peek PgfConcr, cflags) (concr c)
   flags   <- peekFlags c_flags
   touchConcr c
   return flags
 
-peekFlags :: Ptr GuSeq -> IO (Map.Map String Literal)
+peekFlags :: Ptr GuSeq -> IO [(String,Literal)]
 peekFlags c_flags = do
   c_len <- (#peek GuSeq, len) c_flags
-  list  <- peekFlags (c_len :: CInt) (c_flags `plusPtr` (#offset GuSeq, data))
-  return (Map.fromAscList list)
+  peekFlags (c_len :: CInt) (c_flags `plusPtr` (#offset GuSeq, data))
   where
     peekFlags 0     ptr = return []
     peekFlags c_len ptr = do
@@ -114,7 +115,7 @@ concrTotalCats c = unsafePerformIO $ do
   touchConcr c
   return (fromIntegral (c_total_cats :: CInt))
 
-concrCategories :: Concr -> [(CId,FId,FId,[String])]
+concrCategories :: Concr -> [(Cat,FId,FId,[String])]
 concrCategories c = 
   unsafePerformIO $
     withGuPool $ \tmpPl ->
@@ -348,7 +349,7 @@ eMeta id =
   alloca $ \pptr -> do
     ptr <- gu_alloc_variant (#const PGF_EXPR_META)
                             (fromIntegral (#size PgfExprMeta))
-                            (#const gu_flex_alignof(PgfExprMeta))
+                            (#const gu_alignof(PgfExprMeta))
                             pptr pool
     (#poke PgfExprMeta, id) ptr (fromIntegral id :: CInt)
     e <- peek pptr
@@ -452,28 +453,51 @@ newHypos hypos pool = do
             Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
             Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
 
-data AbstrInfo = Abstr (Ptr GuSeq) (Ptr GuSeq) (Ptr GuSeq) Touch
 
-newAbstr :: (?builder :: Builder s) => Map.Map String Literal ->
-                                       Map.Map Cat ([B s Hypo],Float) ->
-                                       Map.Map Fun (B s Type,Int,Float) ->
+data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) Touch
+
+newAbstr :: (?builder :: Builder s) => [(String,Literal)] ->
+                                       [(Cat,[B s Hypo],Float)] ->
+                                       [(Fun,B s Type,Int,Float)] ->
                                        AbstrInfo
 newAbstr aflags cats funs = unsafePerformIO $ do
   c_aflags <- newFlags aflags pool
-  c_cats   <- newMap (#size PgfAbsCat) pokeAbsCat cats pool
-  c_funs   <- newMap (#size PgfAbsFun) pokeAbsFun funs pool
-  return (Abstr c_aflags c_cats c_funs touch)
+  (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)
   where
     (Builder pool touch) = ?builder
 
-    pokeAbsCat ptr name (hypos,prob) = do
+    newAbsCats values pool = do
+      c_seq <- gu_make_seq (#size PgfAbsCat) (fromIntegral (length values)) pool
+      abscats <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values
+      return (c_seq,abscats)
+      where
+        pokeElems ptr abscats []     = return abscats
+        pokeElems ptr abscats (x:xs) = do
+          abscats <- pokeAbsCat ptr abscats x
+          pokeElems (ptr `plusPtr` (#size PgfAbsCat)) abscats xs
+
+    pokeAbsCat ptr abscats (name,hypos,prob) = do
       c_name  <- newUtf8CString name pool
       c_hypos <- newHypos hypos pool
       (#poke PgfAbsCat, name) ptr c_name
       (#poke PgfAbsCat, context) ptr c_hypos
       (#poke PgfAbsCat, prob) ptr (realToFrac prob :: CFloat)
+      return (Map.insert name ptr abscats)
 
-    pokeAbsFun ptr name (B (Type c_ty _),arity,prob) = do
+    newAbsFuns values pool = do
+      c_seq <- gu_make_seq (#size PgfAbsFun) (fromIntegral (length values)) pool
+      absfuns <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values
+      return (c_seq,absfuns)
+      where
+        pokeElems ptr absfuns []     = return absfuns
+        pokeElems ptr absfuns (x:xs) = do
+          absfuns <- pokeAbsFun ptr absfuns x
+          pokeElems (ptr `plusPtr` (#size PgfAbsFun)) absfuns xs
+
+    pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,prob) = do
       pfun <- gu_alloc_variant (#const PGF_EXPR_FUN)
                                (fromIntegral ((#size PgfExprFun)+utf8Length name))
                                (#const gu_flex_alignof(PgfExprFun))
@@ -485,42 +509,159 @@ newAbstr aflags cats funs = unsafePerformIO $ do
       (#poke PgfAbsFun, arity) ptr (fromIntegral arity :: CInt)
       (#poke PgfAbsFun, defns) ptr nullPtr
       (#poke PgfAbsFun, ep.prob) ptr (realToFrac prob :: CFloat)
+      return (Map.insert name ptr absfuns)
+
+    newAbsLinFun = do
+      ptr <- gu_malloc_aligned pool
+                               (#size PgfAbsFun)
+                               (#const gu_alignof(PgfAbsFun))
+      c_wild <- newUtf8CString "_" pool
+      c_ty   <- gu_malloc_aligned pool
+                                  (#size PgfType)
+                                  (#const gu_alignof(PgfType))
+      (#poke PgfType, hypos)   c_ty nullPtr
+      (#poke PgfType, cid)     c_ty c_wild
+      (#poke PgfType, n_exprs) c_ty (0 :: CSizeT)
+      (#poke PgfAbsFun, name)    ptr c_wild
+      (#poke PgfAbsFun, type)    ptr c_ty
+      (#poke PgfAbsFun, arity)   ptr (0 :: CSizeT)
+      (#poke PgfAbsFun, defns)   ptr nullPtr
+      (#poke PgfAbsFun, ep.prob) ptr (- log 0 :: CFloat)
+      (#poke PgfAbsFun, ep.expr) ptr nullPtr
+      return ptr
+
+
+data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap)
+
+newConcr :: (?builder :: Builder s) => AbstrInfo ->
+                                       [(String,Literal)] ->       -- ^ Concrete syntax flags
+                                       [(String,String)] ->        -- ^ Printnames
+                                       [(FId,[FunId])] ->          -- ^ Lindefs
+                                       [(FId,[FunId])] ->          -- ^ Linrefs
+                                       [(FId,[Production])] ->     -- ^ Productions
+                                       [(Fun,[SeqId])] ->          -- ^ Concrete functions   (must be sorted by Fun)
+                                       [[Symbol]] ->               -- ^ Sequences            (must be sorted)
+                                       [(Cat,FId,FId,[String])] -> -- ^ Concrete categories
+                                       ConcrInfo
+newConcr (AbstrInfo _ _ abscats  _ absfuns c_abs_lin_fun _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats = unsafePerformIO $ do
+  c_cflags <- newFlags cflags pool
+  c_printname <- newMap (#size GuString) gu_string_hasher newUtf8CString 
+                        (#size GuString) (pokeString pool)
+                        printnames pool
+  c_seqs <- newSequence (#size PgfSequence) pokeSequence sequences pool
+  let seqs_ptr = c_seqs `plusPtr` (#offset GuSeq, data)
+  c_cncfuns <- newSequence (#size PgfCncFun*) (pokeCncFun seqs_ptr) (zip [0..] cncfuns) pool
+  let funs_ptr = c_cncfuns `plusPtr` (#offset GuSeq, data)
+  c_ccats <- gu_make_map (#size int) gu_int_hasher
+                         (#size PgfCCat*) gu_null_struct
+                         (#const GU_MAP_DEFAULT_INIT_SIZE)
+                         pool
+  mapM_ (addLindefs c_ccats funs_ptr) lindefs
+  mapM_ (addLinrefs c_ccats funs_ptr) linrefs
+  mapM_ (addProductions c_ccats funs_ptr) 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)
+  where
+    (Builder pool touch) = ?builder
 
-data ConcrInfo
-
-newPGF :: (?builder :: Builder s) => Map.Map String Literal ->
+    pokeCncFun seqs_ptr ptr cncfun = do
+      c_cncfun <- newCncFun absfuns nullPtr cncfun pool
+      poke ptr c_cncfun
+
+    pokeSequence c_seq syms = do
+      c_syms <- newSymbols syms pool
+      (#poke PgfSequence, syms) c_seq c_syms
+      (#poke PgfSequence, idx)  c_seq nullPtr
+
+    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
+      (#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
+      (#poke PgfCCat, linrefs) c_ccat c_funs
+
+    addProductions c_ccats funs_ptr (fid,prods) = do
+      c_ccat  <- getCCat c_ccats fid pool
+      c_prods <- gu_make_seq (#size PgfProduction) (fromIntegral (length prods)) pool
+      (#poke PgfCCat, prods) c_ccat c_prods
+
+    pokeFunId 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
+
+    pokeCncCat c_ccats ptr (name,start,end,labels) = do
+      let n_lins = fromIntegral (length labels) :: CSizeT
+      c_cnccat <- gu_malloc_aligned pool 
+                                    ((#size PgfCncCat)+n_lins*(#size GuString))
+                                    (#const gu_flex_alignof(PgfCncCat))
+      case Map.lookup name abscats of
+        Just c_abscat -> (#poke PgfCncCat, abscat) c_cnccat c_abscat
+        Nothing       -> throwIO (PGFError ("The category "++name++" is not in the abstract syntax"))
+      c_ccats <- newSequence (#size PgfCCat*) pokeFId [start..end] pool
+      (#poke PgfCncCat, cats) c_cnccat c_ccats
+      pokeLabels (c_cnccat `plusPtr` (#offset PgfCncCat, labels)) labels
+      poke ptr c_cnccat
+      where
+        pokeFId ptr fid = do
+          c_ccat <- getCCat c_ccats fid pool
+          poke ptr c_ccat
+          
+        pokeLabels ptr []     = return []
+        pokeLabels ptr (l:ls) = do
+          c_l <- newUtf8CString l pool
+          poke ptr c_l
+          pokeLabels (ptr `plusPtr` (#size GuString)) ls
+
+
+newPGF :: (?builder :: Builder s) => [(String,Literal)] ->
                                      AbsName ->
                                      AbstrInfo ->
-                                     Map.Map ConcName ConcrInfo ->
+                                     [(ConcName,ConcrInfo)] ->
                                      B s PGF
-newPGF gflags absname (Abstr c_aflags c_cats c_funs _) 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)
                              (#const gu_alignof(PgfPGF))
     c_gflags  <- newFlags gflags pool
     c_absname <- newUtf8CString absname pool
-    c_concrs  <- newMap (#size PgfConcr) pokeConcr concrs pool
+    let c_abstr = ptr `plusPtr` (#offset PgfPGF, abstract)
+    c_concrs  <- newSequence (#size PgfConcr) (pokeConcr c_abstr) concrs pool
     (#poke PgfPGF, major_version)   ptr (2 :: (#type uint16_t))
     (#poke PgfPGF, minor_version)   ptr (0 :: (#type uint16_t))
     (#poke PgfPGF, gflags)          ptr c_gflags
     (#poke PgfPGF, abstract.name)   ptr c_absname
     (#poke PgfPGF, abstract.aflags) ptr c_aflags
-    (#poke PgfPGF, abstract.cats)   ptr c_cats
     (#poke PgfPGF, abstract.funs)   ptr c_funs
+    (#poke PgfPGF, abstract.cats)   ptr c_cats
+    (#poke PgfPGF, abstract.abs_lin_fun) ptr c_abs_lin_fun
     (#poke PgfPGF, concretes)       ptr c_concrs
     (#poke PgfPGF, pool)            ptr pool
     return (B (PGF ptr touch))
   where
     (Builder pool touch) = ?builder
 
-    pokeConcr ptr name concr = do
-      undefined
-
-newFlags :: Map.Map String Literal -> Ptr GuPool -> IO (Ptr GuSeq)
-newFlags flags pool = newMap (#size PgfFlag) pokeFlag flags pool
+    pokeConcr c_abstr ptr (name, ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats) = do
+      c_name <- newUtf8CString name 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, cncfuns)    ptr c_cncfuns
+      (#poke PgfConcr, sequences)  ptr c_seqs
+      (#poke PgfConcr, cnccats)    ptr c_cnccats
+      (#poke PgfConcr, pool)       ptr nullPtr
+
+
+newFlags :: [(String,Literal)] -> Ptr GuPool -> IO (Ptr GuSeq)
+newFlags flags pool = newSequence (#size PgfFlag) pokeFlag (sortByFst flags) pool
   where
-    pokeFlag c_flag name value = do
+    pokeFlag c_flag (name,value) = do
       c_name  <- newUtf8CString name pool
       c_value <- newLiteral value pool
       (#poke PgfFlag, name)  c_flag c_name
@@ -539,7 +680,7 @@ newLiteral (LInt val) pool =
   alloca $ \pptr -> do
     ptr <- gu_alloc_variant (#const PGF_LITERAL_INT)
                             (fromIntegral (#size PgfLiteralInt))
-                            (#const gu_flex_alignof(PgfLiteralInt))
+                            (#const gu_alignof(PgfLiteralInt))
                             pptr pool
     (#poke PgfLiteralInt, val) ptr (fromIntegral val :: CInt)
     peek pptr
@@ -547,25 +688,178 @@ newLiteral (LFlt val) pool =
   alloca $ \pptr -> do
     ptr <- gu_alloc_variant (#const PGF_LITERAL_FLT)
                             (fromIntegral (#size PgfLiteralFlt))
-                            (#const gu_flex_alignof(PgfLiteralFlt))
+                            (#const gu_alignof(PgfLiteralFlt))
                             pptr pool
     (#poke PgfLiteralFlt, val) ptr (realToFrac val :: CDouble)
     peek pptr
 
-newSymbol :: Symbol -> Ptr GuPool -> IO GuVariant
-newSymbol pool = undefined
+newCncFun absfuns seqs_ptr (funid,(fun,seqids)) pool =
+  do let c_absfun = fromMaybe nullPtr (Map.lookup fun absfuns)
+         c_ep     = if c_absfun == nullPtr
+                      then nullPtr
+                      else c_absfun `plusPtr` (#offset PgfAbsFun, ep)
+         n_lins   = fromIntegral (length seqids) :: CSizeT
+     ptr <- gu_malloc_aligned pool
+                              ((#size PgfCncFun)+n_lins*(#size PgfSequence*))
+                              (#const gu_flex_alignof(PgfCncFun))
+     (#poke PgfCncFun, absfun) ptr c_absfun
+     (#poke PgfCncFun, ep)     ptr c_ep
+     (#poke PgfCncFun, funid)  ptr (funid :: CInt)
+     (#poke PgfCncFun, n_lins) ptr n_lins
+     pokeSequences seqs_ptr (ptr `plusPtr` (#offset PgfCncFun, lins)) seqids
+     return ptr
+  where
+    pokeSequences seqs_ptr ptr []             = return ()
+    pokeSequences seqs_ptr ptr (seqid:seqids) = do
+      poke ptr (seqs_ptr `plusPtr` (seqid * (#size PgfSequence)))
+      pokeSequences seqs_ptr (ptr `plusPtr` (#size PgfSequence*)) seqids
+
+getCCat c_ccats fid pool =
+  alloca $ \pfid -> do
+    poke pfid (fromIntegral fid :: CInt)
+    ptr <- gu_map_find_default c_ccats pfid
+    c_ccat <- peek ptr
+    if c_ccat /= nullPtr
+      then return c_ccat
+      else do c_ccat <- gu_malloc_aligned pool
+                                          (#size PgfCCat)
+                                          (#const gu_alignof(PgfCCat))
+              (#poke PgfCCat, cnccat) c_ccat nullPtr
+              (#poke PgfCCat, lindefs) c_ccat nullPtr
+              (#poke PgfCCat, linrefs) c_ccat nullPtr
+              (#poke PgfCCat, n_synprods) c_ccat (0 :: CSizeT)
+              (#poke PgfCCat, prods) c_ccat nullPtr
+              (#poke PgfCCat, viterbi_prob) c_ccat (0 :: CFloat)
+              (#poke PgfCCat, fid) c_ccat fid
+              (#poke PgfCCat, conts) c_ccat nullPtr
+              (#poke PgfCCat, answers) c_ccat nullPtr
+              ptr <- gu_map_insert c_ccats pfid
+              poke ptr c_ccat
+              return c_ccat
 
-newMap :: CSizeT -> (Ptr a -> k -> v -> IO ()) -> Map.Map k v -> Ptr GuPool -> IO (Ptr GuSeq)
-newMap elem_size pokeElem m pool = do
-  c_m <- gu_make_seq elem_size (fromIntegral (Map.size m)) pool
-  pokeElems (c_m `plusPtr` (#offset GuSeq, data)) (Map.toAscList m)
-  return c_m
+newSymbol :: Symbol -> Ptr GuPool -> IO GuVariant
+newSymbol (SymCat d r)     pool = alloca $ \pptr -> do
+                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAT)
+                                                            (fromIntegral (#size PgfSymbolCat))
+                                                            (#const gu_alignof(PgfSymbolCat))
+                                                            pptr pool
+                                    (#poke PgfSymbolCat, d) ptr (fromIntegral d :: CInt)
+                                    (#poke PgfSymbolCat, r) ptr (fromIntegral r :: CInt)
+                                    peek pptr
+newSymbol (SymLit d r)     pool = alloca $ \pptr -> do
+                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_LIT)
+                                                            (fromIntegral (#size PgfSymbolLit))
+                                                            (#const gu_alignof(PgfSymbolLit))
+                                                            pptr pool
+                                    (#poke PgfSymbolLit, d) ptr (fromIntegral d :: CInt)
+                                    (#poke PgfSymbolLit, r) ptr (fromIntegral r :: CInt)
+                                    peek pptr
+newSymbol (SymVar d r)     pool = alloca $ \pptr -> do
+                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_VAR)
+                                                            (fromIntegral (#size PgfSymbolVar))
+                                                            (#const gu_alignof(PgfSymbolVar))
+                                                            pptr pool
+                                    (#poke PgfSymbolVar, d) ptr (fromIntegral d :: CInt)
+                                    (#poke PgfSymbolVar, r) ptr (fromIntegral r :: CInt)
+                                    peek pptr
+newSymbol (SymKS t)        pool = alloca $ \pptr -> do
+                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_KS)
+                                                            (fromIntegral ((#size PgfSymbolKS)+utf8Length t))
+                                                            (#const gu_flex_alignof(PgfSymbolKS))
+                                                            pptr pool
+                                    pokeUtf8CString t (ptr `plusPtr` (#offset PgfSymbolKS, token))
+                                    peek pptr
+newSymbol (SymKP def alts) pool = alloca $ \pptr -> do
+                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_KP)
+                                                            (fromIntegral ((#size PgfSymbolKP)+(length alts * (#size PgfAlternative))))
+                                                            (#const gu_flex_alignof(PgfSymbolKP))
+                                                            pptr pool
+                                    c_def <- newSymbols def pool
+                                    (#poke PgfSymbolKP, default_form) ptr c_def
+                                    pokeAlternatives (ptr `plusPtr` (#offset PgfSymbolKP, forms)) alts pool
+                                    peek pptr
+newSymbol SymBIND          pool = alloca $ \pptr -> do
+                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_BIND)
+                                                            (fromIntegral (#size PgfSymbolBIND))
+                                                            (#const gu_alignof(PgfSymbolBIND))
+                                                            pptr pool
+                                    peek pptr
+newSymbol SymNE            pool = alloca $ \pptr -> do
+                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_NE)
+                                                            (fromIntegral (#size PgfSymbolNE))
+                                                            (#const gu_alignof(PgfSymbolNE))
+                                                            pptr pool
+                                    peek pptr
+newSymbol SymSOFT_BIND     pool = alloca $ \pptr -> do
+                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_BIND)
+                                                            (fromIntegral (#size PgfSymbolBIND))
+                                                            (#const gu_alignof(PgfSymbolBIND))
+                                                            pptr pool
+                                    peek pptr
+newSymbol SymSOFT_SPACE    pool = alloca $ \pptr -> do
+                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_SPACE)
+                                                            (fromIntegral (#size PgfSymbolBIND))
+                                                            (#const gu_alignof(PgfSymbolBIND))
+                                                            pptr pool
+                                    peek pptr
+newSymbol SymCAPIT         pool = alloca $ \pptr -> do
+                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAPIT)
+                                                            (fromIntegral (#size PgfSymbolCAPIT))
+                                                            (#const gu_alignof(PgfSymbolCAPIT))
+                                                            pptr pool
+                                    peek pptr
+newSymbol SymALL_CAPIT     pool = alloca $ \pptr -> do
+                                    ptr <- gu_alloc_variant (#const PGF_SYMBOL_ALL_CAPIT)
+                                                            (fromIntegral (#size PgfSymbolCAPIT))
+                                                            (#const gu_alignof(PgfSymbolCAPIT))
+                                                            pptr pool
+                                    peek pptr
+
+newSymbols syms pool = newSequence (#size PgfSymbol) pokeSymbol syms pool
   where
-    pokeElems ptr []               = return ()
-    pokeElems ptr ((key,value):xs) = do
-      pokeElem  ptr key value
+    pokeSymbol p_sym sym = do
+      c_sym <- newSymbol sym pool
+      poke p_sym c_sym
+
+pokeAlternatives ptr []                     pool = return ()
+pokeAlternatives ptr ((syms,prefixes):alts) pool = do
+  c_syms     <- newSymbols syms pool
+  c_prefixes <- newSequence (#size GuString) (pokeString pool) prefixes pool
+  (#poke PgfAlternative, form)     ptr c_syms
+  (#poke PgfAlternative, prefixes) ptr c_prefixes
+  pokeAlternatives (ptr `plusPtr` (#size PgfAlternative)) alts pool
+
+pokeString pool c_elem str = do
+  c_str <- newUtf8CString str pool
+  poke c_elem c_str
+
+newSequence :: CSizeT -> (Ptr a -> v -> IO ()) -> [v] -> Ptr GuPool -> IO (Ptr GuSeq)
+newSequence elem_size pokeElem values pool = do
+  c_seq <- gu_make_seq elem_size (fromIntegral (length values)) pool
+  pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) values
+  return c_seq
+  where
+    pokeElems ptr []     = return ()
+    pokeElems ptr (x:xs) = do
+      pokeElem  ptr x
       pokeElems (ptr `plusPtr` (fromIntegral elem_size)) xs
 
+newMap key_size hasher newKey elem_size pokeElem values pool = do
+  map <- gu_make_map key_size hasher
+                     elem_size gu_null_struct
+                     (#const GU_MAP_DEFAULT_INIT_SIZE)
+                     pool
+  insert map values pool
+  return map
+  where
+    insert map []                  pool = return ()
+    insert map ((key,elem):values) pool = do
+      c_key  <- newKey key pool
+      c_elem <- gu_map_insert map c_key
+      pokeElem c_elem elem
+      insert map values pool
+
+
 writePGF :: FilePath -> PGF -> IO ()
 writePGF fpath p = do
   pool <- gu_new_pool
@@ -585,3 +879,7 @@ writePGF fpath p = do
                       throwIO (PGFError "The grammar cannot be stored")
     else do gu_pool_free pool
             return ()
+
+sortByFst  = sortBy (\(x,_)     (y,_)     -> compare x y)
+sortByFst3 = sortBy (\(x,_,_)   (y,_,_)   -> compare x y)
+sortByFst4 = sortBy (\(x,_,_,_) (y,_,_,_) -> compare x y)