implemented categoryContext

src/runtime/haskell/PGF2.hsc

@@ -19,7 +19,7 @@ module PGF2 (-- * PGF
              -- * Abstract syntax
              AbsName,abstractName,
              -- ** Categories
-             Cat,categories,
+             Cat,categories,categoryContext,
              -- ** Functions
              Fun, functions, functionsByCat,
              functionType,
@@ -163,6 +163,34 @@ categories p =
       name  <- peekText key
       writeIORef ref $ (name : names)
 
+categoryContext :: PGF -> Cat -> [Hypo]
+categoryContext p cat =
+  unsafePerformIO $
+  withText cat $ \c_cat ->
+  alloca $ \p_n_hypos ->
+  withForeignPtr (a_pgf p) $ \c_pgf ->
+  mask_ $ do
+    c_hypos <- pgf_category_context c_pgf c_cat p_n_hypos
+    if c_hypos == nullPtr
+      then return []
+      else do n_hypos <- peek p_n_hypos
+              hypos <- peekHypos c_hypos 0 n_hypos
+              free c_hypos
+              return hypos
+  where
+    peekHypos :: Ptr PgfTypeHypo -> CSize -> CSize -> IO [Hypo]
+    peekHypos c_hypo i n
+      | i < n     = do c_cat <- (#peek PgfTypeHypo, cid) c_hypo
+                       cat <- peekText c_cat
+                       free c_cat
+                       c_ty <- (#peek PgfTypeHypo, type) c_hypo
+                       ty <- deRefStablePtr c_ty
+                       freeStablePtr c_ty
+                       bt  <- fmap unmarshalBindType ((#peek PgfTypeHypo, bind_type) c_hypo)
+                       hs <- peekHypos (plusPtr c_hypo (#size PgfTypeHypo)) (i+1) n
+                       return ((bt,cat,ty) : hs)
+      | otherwise = return []
+
 -- | List of all functions defined in the abstract syntax
 functions :: PGF -> [Fun]
 functions p =

src/runtime/haskell/PGF2/FFI.hsc

@@ -63,6 +63,9 @@ foreign import ccall "wrapper"
 foreign import ccall "pgf_iter_categories"
   pgf_iter_categories :: Ptr PgfPGF -> Ptr PgfItor -> IO ()
 
+foreign import ccall "pgf/pgf.h pgf_category_context"
+  pgf_category_context :: Ptr PgfPGF -> Ptr PgfText -> Ptr CSize -> IO (Ptr PgfTypeHypo)
+
 foreign import ccall "pgf_iter_functions"
   pgf_iter_functions :: Ptr PgfPGF -> Ptr PgfItor -> IO ()
 

src/runtime/haskell/tests/basic.gf

@@ -7,4 +7,7 @@ fun z : N ;
 
 fun c : N -> S ;
 
+cat P N ;
+fun ind : P z -> ((x:N) -> P x -> P (s x)) -> ((x : N) -> P x) ;
+
 }

src/runtime/haskell/tests/basic.hs

@@ -5,13 +5,18 @@ main = do
   gr <- readPGF "tests/basic.pgf"
   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 categories" ["Float","Int","N","P","S","String"] (categories gr))
+             ,TestCase (assertEqual "abstract functions" ["c","ind","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"))
+             ,TestCase (assertEqual "abstract functions by cat 2" [] (functionsByCat gr "X")) -- no such category
              ,TestCase (assertBool  "type of z" (eqJust (readType "N")    (functionType gr "z")))
              ,TestCase (assertBool  "type of s" (eqJust (readType "N->N") (functionType gr "s")))
              ,TestCase (assertBool  "type of c" (eqJust (readType "N->S") (functionType gr "c")))
+             ,TestCase (assertEqual "category context 1"  [] (categoryContext gr "N"))
+             ,TestCase (assertEqual "category context 1"  [] (categoryContext gr "S"))
+             ,TestCase (assertEqual "category context 1"  [(Explicit,"_",DTyp [] "N" [])] (categoryContext gr "P"))
+             ,TestCase (assertEqual "category context 1"  [] (categoryContext gr "X")) -- no such category
              ]
 
 eqJust (Just x) (Just y) = x == y