API for scanning for cohorts in an arbitrary text

src/runtime/haskell-bind/PGF2.hsc

@@ -70,7 +70,7 @@ module PGF2 (-- * PGF
              -- ** Generation
              generateAll,
              -- ** Morphological Analysis
-             MorphoAnalysis, lookupMorpho, fullFormLexicon,
+             MorphoAnalysis, lookupMorpho, lookupCohorts, fullFormLexicon,
              -- ** Visualizations
              GraphvizOptions(..), graphvizDefaults,
              graphvizAbstractTree, graphvizParseTree, graphvizWordAlignment,
@@ -481,6 +481,36 @@ lookupMorpho (Concr concr master) sent =
        freeHaskellFunPtr fptr
        readIORef ref
 
+lookupCohorts :: Concr -> String -> [(Int,[MorphoAnalysis],Int)]
+lookupCohorts lang@(Concr concr master) sent =
+  unsafePerformIO $
+    do pl <- gu_new_pool
+       ref <- newIORef []
+       cback <- gu_malloc pl (#size PgfMorphoCallback)
+       fptr <- wrapLookupMorphoCallback (getAnalysis ref)
+       (#poke PgfMorphoCallback, callback) cback fptr
+       c_sent <- newUtf8CString sent pl
+       enum <- pgf_lookup_cohorts concr c_sent cback pl nullPtr
+       fpl <- newForeignPtr gu_pool_finalizer pl
+       fromCohortRange enum fpl fptr ref
+  where
+    fromCohortRange enum fpl fptr ref =
+      allocaBytes (#size PgfCohortRange) $ \ptr ->
+      withForeignPtr fpl $ \pl ->
+        do gu_enum_next enum ptr pl
+           buf <- (#peek PgfCohortRange, buf) ptr
+           if buf == nullPtr
+             then do finalizeForeignPtr fpl
+                     freeHaskellFunPtr fptr
+                     touchConcr lang
+                     return []
+             else do start <- (#peek PgfCohortRange, start.pos) ptr
+                     end   <- (#peek PgfCohortRange, end.pos)   ptr
+                     ans   <- readIORef ref
+                     writeIORef ref []
+                     cohs  <- unsafeInterleaveIO (fromCohortRange enum fpl fptr ref)
+                     return ((start,ans,end):cohs)
+
 fullFormLexicon :: Concr -> [(String, [MorphoAnalysis])]
 fullFormLexicon lang =
   unsafePerformIO $

src/runtime/haskell-bind/PGF2/FFI.hsc

@@ -100,7 +100,7 @@ foreign import ccall unsafe "gu/string.h gu_string_buf_out"
 foreign import ccall unsafe "gu/file.h gu_file_in"
   gu_file_in :: Ptr () -> Ptr GuPool -> IO (Ptr GuIn)
 
-foreign import ccall unsafe "gu/enum.h gu_enum_next"
+foreign import ccall safe  "gu/enum.h gu_enum_next"
   gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO ()
  
 foreign import ccall unsafe "gu/string.h gu_string_buf_freeze"
@@ -401,6 +401,9 @@ foreign import ccall "pgf/pgf.h pgf_parse_with_oracle"
 foreign import ccall "pgf/pgf.h pgf_lookup_morpho"
   pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
 
+foreign import ccall "pgf/pgf.h pgf_lookup_cohorts"
+  pgf_lookup_cohorts :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuEnum)
+
 type LookupMorphoCallback = Ptr PgfMorphoCallback -> CString -> CString -> Float -> Ptr GuExn -> IO ()
 
 foreign import ccall "wrapper"