GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
Cached parse results are discarded when they have been unused for 10 minutes.
This commit is contained in:
hallgren
2014-01-27 16:32:09 +00:00
parent 88341987a8
commit b3251f402d
1 changed files with 36 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files

55
src/server/PGFService.hs
View File

@@ -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 command pgf =
cpgfMain :: String -> (C.PGF,MVar ParseCache) -> CGI CGIResult
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 =
showJSON [makeObj ("from".=from:"trees".=trees :[])]
-- :addTrie trie trees
parse input (from,concr) start mlimit trie =
do trees <- parse' input (from,concr) start mlimit
return $ showJSON [makeObj ("from".=from:"trees".=trees :[])]
-- :addTrie trie trees
where
trees = parse' input concr mlimit
parse' input concr mlimit =
map fst $ -- hmm
maybe id take mlimit (C.parse concr (C.startCat pgf) input)
parse' input (from,concr) start mlimit =
liftIO $ do t <- getCurrentTime
(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 =
showJSON [ makeObj ["from".=from,
"translations".=
[makeObj ["tree".=tree,
"linearizations".=lin' tree tos]
| tree <- parse' input concr mlimit]]]
trans input (from,concr) tos start mlimit trie =
do trees <- parse' input (from,concr) start mlimit
return $
showJSON [ makeObj ["from".=from,
"translations".=
[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"