diff options
Diffstat (limited to 'src/server')
| -rw-r--r-- | src/server/Cache.hs | 4 | ||||
| -rw-r--r-- | src/server/PGFService.hs | 22 |
2 files changed, 18 insertions, 8 deletions
diff --git a/src/server/Cache.hs b/src/server/Cache.hs index d7c806783..bde07745a 100644 --- a/src/server/Cache.hs +++ b/src/server/Cache.hs @@ -4,6 +4,7 @@ import Control.Concurrent.MVar import Data.Map (Map) import qualified Data.Map as Map import System.Directory (getModificationTime) +import System.Mem(performGC) import Data.Time (UTCTime) import Data.Time.Compat (toUTCTime) @@ -18,7 +19,8 @@ newCache load = return $ Cache { cacheLoad = load, cacheObjects = objs } flushCache :: Cache a -> IO () -flushCache c = modifyMVar_ (cacheObjects c) (const (return Map.empty)) +flushCache c = do modifyMVar_ (cacheObjects c) (const (return Map.empty)) + performGC readCache :: Cache a -> FilePath -> IO a readCache c file = snd `fmap` readCache' c file diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 3918bc9e5..d12e79ac4 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -47,14 +47,14 @@ logFile :: FilePath logFile = "pgf-error.log" #ifdef C_RUNTIME -type Caches = (Cache PGF,Cache (C.PGF,MVar ParseCache)) -type ParseCache = Map.Map (String,String) (ParseResult,UTCTime) -type ParseResult = Either String [(C.Expr,Float)] +type Caches = (Cache PGF,Cache (C.PGF,({-MVar ParseCache-}))) +--type ParseCache = Map.Map (String,String) (ParseResult,UTCTime) +--type ParseResult = Either String [(C.Expr,Float)] newPGFCache = do pgfCache <- newCache PGF.readPGF cCache <- newCache $ \ path -> do pgf <- C.readPGF path - pc <- newMVar Map.empty - return (pgf,pc) + --pc <- newMVar Map.empty + return (pgf,({-pc-})) return (pgfCache,cCache) flushPGFCache (c1,c2) = flushCache c1 >> flushCache c2 #else @@ -102,7 +102,7 @@ cpgfMain command (t,(pgf,pc)) = "c-grammar" -> out t grammar _ -> badRequest "Unknown command" command where - flush = liftIO $ do modifyMVar_ pc $ const $ return Map.empty + flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty performGC return $ showJSON () @@ -123,6 +123,12 @@ cpgfMain command (t,(pgf,pc)) = good trees = "trees".=map tp trees :[] -- :addTrie trie trees tp (tree,prob) = makeObj ["tree".=tree,"prob".=prob] + -- Without caching parse results: + parse' start mlimit ((_,concr),input) = + return $ + maybe id take mlimit . drop start # C.parse concr (C.startCat pgf) input +{- + -- Caching parse results: parse' start mlimit ((from,concr),input) = liftIO $ do t <- getCurrentTime fmap (maybe id take mlimit . drop start) @@ -137,7 +143,7 @@ cpgfMain command (t,(pgf,pc)) = update r = Map.mapMaybe purge . Map.insert key r purge r@(_,t') = if diffUTCTime t t'<120 then Just r else Nothing -- remove unused parse results after 2 minutes - +-} lin tree to = showJSON (lin' tree to) lin' tree (tos,unlex) = [makeObj ["to".=to,"text".=unlex (C.linearize c tree)]|(to,c)<-tos] @@ -836,6 +842,8 @@ langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languag -- * General utilities +infixl 2 #,% + f .= v = (f,showJSON v) f # x = fmap f x f % x = ap f x |