From 24671a612cf044824104cbf64faab0ded6a8579d Mon Sep 17 00:00:00 2001
From: krasimir <krasimir@chalmers.se>
Date: Thu, 26 Jan 2017 13:37:12 +0000
Subject: [PATCH] a better implementation for PGF2.categories

---
 src/runtime/haskell-bind/PGF2.hsc | 20 ++++++++++++++++++--
 1 file changed, 18 insertions(+), 2 deletions(-)

diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc
index a368d9ccd..a6a53e155 100644
--- a/src/runtime/haskell-bind/PGF2.hsc
+++ b/src/runtime/haskell-bind/PGF2.hsc
@@ -628,8 +628,24 @@ functionsByCat p cat =
 -- The categories are defined in the abstract syntax
 -- with the \'cat\' keyword.
 categories :: PGF -> [Cat]
-categories pgf = -- !!! quick hack
-    nub [cat | f<-functions pgf, let (_, cat, _) = unType (functionType pgf f)]
+categories p =
+  unsafePerformIO $
+    withGuPool $ \tmpPl ->
+    allocaBytes (#size GuMapItor) $ \itor -> do
+      exn <- gu_new_exn tmpPl
+      ref <- newIORef []
+      fptr <- wrapMapItorCallback (getCategories ref)
+      (#poke GuMapItor, fn) itor fptr
+      pgf_iter_categories (pgf p) itor exn
+      freeHaskellFunPtr fptr
+      cs <- readIORef ref
+      return (reverse cs)
+  where
+    getCategories :: IORef [String] -> MapItorCallback
+    getCategories ref itor key value exn = do
+      names <- readIORef ref
+      name  <- peekUtf8CString (castPtr key)
+      writeIORef ref $! (name : names)
 
 categoryContext :: PGF -> Cat -> Maybe [Hypo]
 categoryContext pgf cat = Nothing -- !!! not implemented yet TODO