extend the abstract syntax API

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 ->
-  bracket (pgf_abstract_name c_pgf) free $ \c_text ->
+  withForeignPtr (a_pgf p) $ \p_pgf ->
+  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 ;
-    S : N -> N ;
+fun z : 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"))
+             ]