PGFService.hs: add a cache for C run-time parse result and a start offset parameter

Cached parse results are discarded when they have been unused for 10 minutes.

src/server/PGFService.hs

@@ -12,6 +12,7 @@ import URLEncoding
 #if C_RUNTIME
 import qualified CRuntimeFFI as C
 import qualified CId as C
+import Data.Time.Clock(UTCTime,getCurrentTime,diffUTCTime)
 #endif
 
 import Network.CGI
@@ -43,9 +44,12 @@ logFile :: FilePath
 logFile = "pgf-error.log"
 
 #ifdef C_RUNTIME
-type Caches = (Cache PGF,Cache C.PGF)
+type Caches = (Cache PGF,Cache (C.PGF,MVar ParseCache))
+type ParseCache = Map.Map (C.Language,String) ([(C.Expr,Float)],UTCTime)
 newPGFCache = do pgfCache <- newCache PGF.readPGF
-                 cCache <- newCache C.readPGF 
+                 cCache <- newCache $ \ path -> do pgf <- C.readPGF path
+                                                   pc <- newMVar Map.empty
+                                                   return (pgf,pc)
                  return (pgfCache,cCache)
 #else
 type Caches = (Cache PGF,())
@@ -78,33 +82,45 @@ cgiMain' cache path =
 -- * C run-time functionality
 
 #ifdef C_RUNTIME
-cpgfMain :: String -> C.PGF -> CGI CGIResult
+cpgfMain :: String -> (C.PGF,MVar ParseCache) -> CGI CGIResult
-cpgfMain command pgf =
+cpgfMain command (pgf,pc) =
   case command of
-    "c-parse"     -> out =<< parse # input % from % limit % trie
+    "c-parse"     -> out =<< join (parse # input % from % start % limit % trie)
     "c-linearize" -> out =<< lin # tree % to
-    "c-translate" -> out =<< trans # input % from % to % limit % trie
+    "c-translate" -> out =<< join (trans # input % from % to % start % limit % trie)
     _             -> badRequest "Unknown command" command
   where
-    parse input (from,concr) mlimit trie =
+    parse input (from,concr) start mlimit trie =
-        showJSON [makeObj ("from".=from:"trees".=trees :[])]
+        do trees <- parse' input (from,concr) start mlimit
-                                                    -- :addTrie trie trees
+           return $ showJSON [makeObj ("from".=from:"trees".=trees :[])]
+                                                        -- :addTrie trie trees
       where
-        trees = parse' input concr mlimit
 
-    parse' input concr mlimit = 
+    parse' input (from,concr) start mlimit = 
-        map fst $ -- hmm
+        liftIO $ do t <- getCurrentTime
-        maybe id take mlimit (C.parse concr (C.startCat pgf) input)
+                    (map fst . maybe id take mlimit . drop start)
+                      # modifyMVar pc (parse'' t)
+      where
+        key = (from,input)
+        parse'' t pc = maybe new old $ Map.lookup key pc
+          where
+            new = return (update (res,t) pc,res)
+              where res = C.parse concr (C.startCat pgf) input
+            old (res,_) = return (update (res,t) pc,res)
+            update r = Map.mapMaybe purge . Map.insert key r
+            purge r@(_,t') = if diffUTCTime t t'<600 then Just r else Nothing
 
     lin tree tos = showJSON (lin' tree tos)
     lin' tree tos = [makeObj ["to".=to,"text".=C.linearize c tree]|(to,c)<-tos]
 
-    trans input (from,concr) tos mlimit trie =
+    trans input (from,concr) tos start mlimit trie =
-      showJSON [ makeObj ["from".=from,
+      do trees <- parse' input (from,concr) start mlimit
-                          "translations".=
+         return $
-                            [makeObj ["tree".=tree,
+           showJSON [ makeObj ["from".=from,
-                                      "linearizations".=lin' tree tos]
+                               "translations".=
-                              | tree <- parse' input concr mlimit]]]
+                                 [makeObj ["tree".=tree,
+                                           "linearizations".=lin' tree tos]
+                                  | tree <- trees]]]
 
     from = maybe (missing "from") return =<< getLang "from"
     
@@ -249,6 +265,7 @@ getLang' readLang i =
 limit, depth :: CGI (Maybe Int)
 limit = readInput "limit"
 depth = readInput "depth"
+start = maybe 0 id # readInput "start"
 
 trie :: CGI Bool
 trie = maybe False toBool # getInput "trie"