extend the abstract syntax API

src/runtime/c/namespace.h

@@ -187,21 +187,24 @@ public:
 };
 
 template <class V>
-Namespace<V> namespace_empty() {
+Namespace<V> namespace_empty()
+{
     return 0;
 }
 
 template <class V>
-Namespace<V> namespace_singleton(ref<V> value) {
+Namespace<V> namespace_singleton(ref<V> value)
+{
     return Node<V>::new_node(value);
 }
 
 template <class V>
-Namespace<V> namespace_insert(Namespace<V> map, ref<V> value) {
+Namespace<V> namespace_insert(Namespace<V> map, ref<V> value)
+{
     if (map == 0)
         return Node<V>::new_node(value);
 
-    int cmp = textcmp(value->name,map->value->name);
+    int cmp = textcmp(&value->name,&map->value->name);
     if (cmp < 0) {
         Namespace<V> left = namespace_insert(map->left, value);
         return Node<V>::balanceL(map->value,left,map->right);
@@ -213,7 +216,8 @@ Namespace<V> namespace_insert(Namespace<V> map, ref<V> value) {
 }
 
 template <class V>
-ref<V> namespace_lookup(Namespace<V> map, const char *name) {
+ref<V> namespace_lookup(Namespace<V> map, const char *name)
+{
     while (map != 0) {
         int cmp = strcmp(name,map->value->name);
         if (cmp < 0)
@@ -227,9 +231,21 @@ ref<V> namespace_lookup(Namespace<V> map, const char *name) {
 }
 
 template <class V>
-size_t namespace_size(Namespace<V> map) {
+size_t namespace_size(Namespace<V> map)
+{
     if (map == 0)
         return 0;
     return map->sz;
 }
+
+template <class V>
+void namespace_iter(Namespace<V> map, PgfItor* itor)
+{
+    if (map == 0)
+        return;
+
+    namespace_iter(map->left, itor);
+    itor->fn(itor, &map->value->name, &(*map->value));
+    namespace_iter(map->right, itor);
+}
 #endif

src/runtime/c/pgf.cxx

@@ -66,3 +66,40 @@ PgfText *pgf_abstract_name(PgfPGF* pgf)
 {
 	return textdup(&(*pgf->get_root<PgfPGFRoot>()->abstract.name));
 }
+
+PGF_API
+void pgf_iter_categories(PgfPGF* pgf, PgfItor* itor)
+{
+	namespace_iter(pgf->get_root<PgfPGFRoot>()->abstract.cats, itor);
+}
+
+PGF_API
+void pgf_iter_functions(PgfPGF* pgf, PgfItor* itor)
+{
+    namespace_iter(pgf->get_root<PgfPGFRoot>()->abstract.funs, itor);
+}
+
+struct PgfItorHelper : PgfItor
+{
+    PgfText *cat;
+    PgfItor *itor;
+};
+
+static
+void iter_by_cat_helper(PgfItor* itor, PgfText* key, void* value)
+{
+    PgfItorHelper* helper = (PgfItorHelper*) itor;
+    PgfAbsFun* absfun = (PgfAbsFun*) value;
+    if (textcmp(helper->cat, &absfun->type->name) == 0)
+        helper->itor->fn(helper->itor, key, value);
+}
+
+PGF_API
+void pgf_iter_functions_by_cat(PgfPGF* pgf, PgfText* cat, PgfItor* itor)
+{
+    PgfItorHelper helper;
+    helper.fn   = iter_by_cat_helper;
+    helper.cat  = cat;
+    helper.itor = itor;
+    namespace_iter(pgf->get_root<PgfPGFRoot>()->abstract.funs, &helper);
+}

src/runtime/c/pgf.h

@@ -43,6 +43,13 @@ typedef struct {
     char text[];
 } PgfText;
 
+/* A generic structure to pass a callback for iteration over a collection */
+typedef struct PgfItor PgfItor;
+
+struct PgfItor {
+	void (*fn)(PgfItor* self, PgfText* key, void *value);
+};
+
 typedef struct PgfPGF PgfPGF;
 
 /* All functions that may fail take a reference to a PgfExn structure.
@@ -79,4 +86,16 @@ PgfPGF *pgf_read(const char* fpath, PgfExn* err);
 PGF_API_DECL
 void pgf_free(PgfPGF *pgf);
 
+PGF_API_DECL
+PgfText *pgf_abstract_name(PgfPGF* pgf);
+
+PGF_API_DECL
+void pgf_iter_categories(PgfPGF* pgf, PgfItor* itor);
+
+PGF_API_DECL
+void pgf_iter_functions(PgfPGF* pgf, PgfItor* itor);
+
+PGF_API
+void pgf_iter_functions_by_cat(PgfPGF* pgf, PgfText* cat, PgfItor* itor);
+
 #endif // PGF_H_

src/runtime/c/text.cxx

@@ -1,20 +1,18 @@
 #include "data.h"
 
 PGF_INTERNAL
-int textcmp(PgfText &t1, PgfText &t2)
+int textcmp(PgfText *t1, PgfText *t2)
 {
     for (size_t i = 0; ; i++) {
-        if (i >= t1.size)
+        if (i >= t1->size)
-            return (i - t2.size);
+            return (i - t2->size);
-        if (i >= t2.size)
+        if (i >= t2->size)
             return 1;
 
-        if (t1.text[i] > t2.text[i])
+        if (t1->text[i] > t2->text[i])
             return 1;
-        else if (t1.text[i] < t2.text[i])
+        else if (t1->text[i] < t2->text[i])
             return -1;
-
-        i++;
     }
 }
 
@@ -52,4 +50,42 @@ pgf_utf8_decode(const uint8_t** src_inout)
 	return u;
 }
 
-
+PGF_API void
+pgf_utf8_encode(uint32_t ucs, uint8_t** buf)
+{
+	uint8_t* p = *buf;
+	if (ucs < 0x80) {
+		p[0] = (uint8_t) ucs;
+		*buf = p+1;
+	} else if (ucs < 0x800) {
+		p[0] = 0xc0 | (ucs >> 6);
+		p[1] = 0x80 | (ucs & 0x3f);
+		*buf = p+2;
+	} else if (ucs < 0x10000) {
+		p[0] = 0xe0 | (ucs >> 12);
+		p[1] = 0x80 | ((ucs >> 6) & 0x3f);
+		p[2] = 0x80 | (ucs & 0x3f);
+		*buf = p+3;
+	} else if (ucs < 0x200000) {
+		p[0] = 0xf0 | (ucs >> 18);
+		p[1] = 0x80 | ((ucs >> 12) & 0x3f);
+		p[2] = 0x80 | ((ucs >> 6) & 0x3f);
+		p[3] = 0x80 | (ucs & 0x3f);
+		*buf = p+4;
+	} else if (ucs < 0x4000000) {
+		p[0] = 0xf8 | (ucs >> 24);
+		p[1] = 0x80 | ((ucs >> 18) & 0x3f);
+		p[2] = 0x80 | ((ucs >> 12) & 0x3f);
+		p[3] = 0x80 | ((ucs >>  6) & 0x3f);
+		p[4] = 0x80 | (ucs & 0x3f);
+		*buf = p+5;
+	} else {
+		p[0] = 0xfc | (ucs >> 30);
+		p[1] = 0x80 | ((ucs >> 24) & 0x3f);
+		p[2] = 0x80 | ((ucs >> 18) & 0x3f);
+		p[3] = 0x80 | ((ucs >> 12) & 0x3f);
+		p[4] = 0x80 | ((ucs >> 6) & 0x3f);
+		p[5] = 0x80 | (ucs & 0x3f);
+		*buf = p+6;
+	}
+}

src/runtime/c/text.h

@@ -2,7 +2,7 @@
 #define TEXT_H
 
 PGF_INTERNAL_DECL
-int textcmp(PgfText &t1, PgfText &t2);
+int textcmp(PgfText *t1, PgfText *t2);
 
 PGF_INTERNAL_DECL
 PgfText* textdup(PgfText *t1);

src/runtime/haskell/PGF2.hsc

@@ -18,6 +18,10 @@ module PGF2 (-- * PGF
 
              -- * Abstract syntax
              AbsName,abstractName,
+             -- ** Categories
+             Cat,categories,
+             -- ** Functions
+             Fun, functions, functionsByCat,
 
              -- * Concrete syntax
              ConcName
@@ -25,12 +29,14 @@ module PGF2 (-- * PGF
 
 import Control.Exception(Exception,throwIO,mask_,bracket)
 import System.IO.Unsafe(unsafePerformIO)
+import PGF2.Expr
 import PGF2.FFI
 
 import Foreign
 import Foreign.C
 import Data.Typeable
 import qualified Data.Map as Map
+import Data.IORef
 
 #include <pgf.h>
 
@@ -60,10 +66,68 @@ readPGF fpath =
 abstractName :: PGF -> AbsName
 abstractName p =
   unsafePerformIO $
-  withForeignPtr (a_pgf p) $ \c_pgf ->
+  withForeignPtr (a_pgf p) $ \p_pgf ->
-  bracket (pgf_abstract_name c_pgf) free $ \c_text ->
+  bracket (pgf_abstract_name p_pgf) free $ \c_text ->
     peekText c_text
 
+-- | List of all functions defined in the abstract syntax
+categories :: PGF -> [Fun]
+categories p =
+  unsafePerformIO $ do
+    ref <- newIORef []
+    (allocaBytes (#size PgfItor) $ \itor ->
+     bracket (wrapItorCallback (getCategories ref)) freeHaskellFunPtr $ \fptr ->
+     withForeignPtr (a_pgf p) $ \p_pgf -> do
+      (#poke PgfItor, fn) itor fptr
+      pgf_iter_categories p_pgf itor
+      cs <- readIORef ref
+      return (reverse cs))
+  where
+    getCategories :: IORef [String] -> ItorCallback
+    getCategories ref itor key = do
+      names <- readIORef ref
+      name  <- peekText key
+      writeIORef ref $ (name : names)
+
+-- | List of all functions defined in the abstract syntax
+functions :: PGF -> [Fun]
+functions p =
+  unsafePerformIO $ do
+    ref <- newIORef []
+    (allocaBytes (#size PgfItor) $ \itor ->
+     bracket (wrapItorCallback (getFunctions ref)) freeHaskellFunPtr $ \fptr ->
+     withForeignPtr (a_pgf p) $ \p_pgf -> do
+      (#poke PgfItor, fn) itor fptr
+      pgf_iter_functions p_pgf itor
+      fs <- readIORef ref
+      return (reverse fs))
+  where
+    getFunctions :: IORef [String] -> ItorCallback
+    getFunctions ref itor key = do
+      names <- readIORef ref
+      name  <- peekText key
+      writeIORef ref $ (name : names)
+
+-- | List of all functions defined in the abstract syntax
+functionsByCat :: PGF -> Cat -> [Fun]
+functionsByCat p cat =
+  unsafePerformIO $ do
+    ref <- newIORef []
+    (withText cat $ \c_cat ->
+     allocaBytes (#size PgfItor) $ \itor ->
+     bracket (wrapItorCallback (getFunctions ref)) freeHaskellFunPtr $ \fptr ->
+     withForeignPtr (a_pgf p) $ \p_pgf -> do
+      (#poke PgfItor, fn) itor fptr
+      pgf_iter_functions_by_cat p_pgf c_cat itor
+      fs <- readIORef ref
+      return (reverse fs))
+  where
+    getFunctions :: IORef [String] -> ItorCallback
+    getFunctions ref itor key = do
+      names <- readIORef ref
+      name  <- peekText key
+      writeIORef ref $ (name : names)
+
 -----------------------------------------------------------------------
 -- Exceptions
 

src/runtime/haskell/PGF2/Expr.hsc

@@ -2,3 +2,5 @@
 
 module PGF2.Expr where
 
+type Cat = String -- ^ Name of syntactic category
+type Fun = String -- ^ Name of function

src/runtime/haskell/PGF2/FFI.hsc

@@ -3,7 +3,7 @@
 module PGF2.FFI where
 
 import Data.Word
-import Foreign ( alloca, peek, poke, peekByteOff )
+import Foreign
 import Foreign.C
 import Foreign.Ptr
 import Foreign.ForeignPtr
@@ -21,21 +21,39 @@ data Concr = Concr {c_pgf :: ForeignPtr PgfPGF, concr :: Ptr PgfConcr}
 
 data PgfExn
 data PgfText
+data PgfItor
 data PgfPGF
 data PgfConcr
 
 foreign import ccall unsafe "pgf_utf8_decode"
   pgf_utf8_decode :: Ptr CString -> IO Word32
 
-foreign import ccall "pgf.h pgf_read"
+foreign import ccall unsafe "pgf_utf8_encode"
+  pgf_utf8_encode :: Word32 -> Ptr CString -> IO ()
+
+foreign import ccall "pgf_read"
   pgf_read :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
 
 foreign import ccall "&pgf_free"
   pgf_free_fptr :: FinalizerPtr PgfPGF
 
-foreign import ccall "pgf/pgf.h pgf_abstract_name"
+foreign import ccall "pgf_abstract_name"
   pgf_abstract_name :: Ptr PgfPGF -> IO (Ptr PgfText)
 
+type ItorCallback = Ptr PgfItor -> Ptr PgfText -> IO ()
+
+foreign import ccall "wrapper"
+  wrapItorCallback :: ItorCallback -> IO (FunPtr ItorCallback)
+
+foreign import ccall "pgf_iter_categories"
+  pgf_iter_categories :: Ptr PgfPGF -> Ptr PgfItor -> IO ()
+
+foreign import ccall "pgf_iter_functions"
+  pgf_iter_functions :: Ptr PgfPGF -> Ptr PgfItor -> IO ()
+
+foreign import ccall "pgf_iter_functions_by_cat"
+  pgf_iter_functions_by_cat :: Ptr PgfPGF -> Ptr PgfText -> Ptr PgfItor -> IO ()
+
 peekText :: Ptr PgfText -> IO String
 peekText ptr =
   alloca $ \pptr -> do
@@ -51,3 +69,35 @@ peekText ptr =
         else do x <- pgf_utf8_decode pptr
                 cs <- decode pptr end
                 return (((toEnum . fromEnum) x) : cs)
+
+withText :: String -> (Ptr PgfText -> IO a) -> IO a
+withText s fn =
+  allocaBytes ((#size PgfText) + size + 1) $ \ptr -> do
+    (#poke PgfText, size) ptr (fromIntegral size :: CSize)
+    pokeUtf8CString s (ptr `plusPtr` (#const offsetof(PgfText, text)))
+    fn ptr
+  where
+    size = utf8Length s
+
+    pokeUtf8CString s ptr =
+      alloca $ \pptr ->
+        poke pptr ptr >> encode s pptr
+      where
+        encode []     pptr = do
+          pgf_utf8_encode 0 pptr
+        encode (c:cs) pptr = do
+          pgf_utf8_encode ((toEnum . fromEnum) c) pptr
+          encode cs pptr
+
+    utf8Length s = count 0 s
+      where
+        count !c []         = c
+        count !c (x:xs)
+          | ucs < 0x80      = count (c+1) xs
+          | ucs < 0x800     = count (c+2) xs
+          | ucs < 0x10000   = count (c+3) xs
+          | ucs < 0x200000  = count (c+4) xs
+          | ucs < 0x4000000 = count (c+5) xs
+          | otherwise       = count (c+6) xs
+          where
+            ucs = fromEnum x

src/runtime/haskell/tests/basic.gf

@@ -1,8 +1,10 @@
 abstract basic = {
 
-cat N ;
+cat N; S ;
 
-fun Z : N ;
+fun z : N ;
-    S : N -> N ;
+    s : N -> N ;
+
+fun c : N -> S ;
 
 }

src/runtime/haskell/tests/basic.hs

@@ -3,4 +3,10 @@ import PGF2
 
 main = do
   gr <- readPGF "tests/basic.pgf"
-  runTestTTAndExit (TestCase (assertEqual "abstract names" "basic" (abstractName gr)))
+  runTestTTAndExit $
+    TestList [TestCase (assertEqual "abstract names" "basic" (abstractName gr))
+             ,TestCase (assertEqual "abstract categories" ["Float","Int","N","S","String"] (categories gr))
+             ,TestCase (assertEqual "abstract functions" ["c","s","z"] (functions gr))
+             ,TestCase (assertEqual "abstract functions by cat 1" ["s","z"] (functionsByCat gr "N"))
+             ,TestCase (assertEqual "abstract functions by cat 2" ["c"] (functionsByCat gr "S"))
+             ]