msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

PGFService.hs: adapt to changes in the Haskell binding to the C run-time system

Browse Source 
Parse errors used to cause crashes, but they are now handled and reported.
This commit is contained in:
hallgren
2014-04-04 12:28:00 +00:00
parent 268e7a697f
commit 57ebfa4416
1 changed files with 20 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
src/server/PGFService.hs
View File

@@ -45,7 +45,9 @@ logFile = "pgf-error.log"
#ifdef C_RUNTIME
type Caches = (Cache PGF,Cache (C.PGF,MVar ParseCache))
type ParseCache = Map.Map (String,String) ([(C.Expr,Float)],UTCTime)
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
@@ -106,15 +108,18 @@ cpgfMain command (pgf,pc) =
languages = [makeObj ["name".= l] | (l,_)<-Map.toList (C.languages pgf)]
parse input (from,concr) start mlimit trie =
do trees <- parse' input (from,concr) start mlimit
return $ showJSON [makeObj ("from".=from:"trees".=map tp trees :[])]
-- :addTrie trie trees
do r <- parse' input (from,concr) start mlimit
return $ showJSON [makeObj ("from".=from:jsonParseResult r)]
tp (tree,prob) = makeObj ["tree".=tree,"prob".=prob]
jsonParseResult = either bad good
where
bad err = ["parseFailed".=err]
good trees = "trees".=map tp trees :[] -- :addTrie trie trees
tp (tree,prob) = makeObj ["tree".=tree,"prob".=prob]
parse' input (from,concr) start mlimit =
liftIO $ do t <- getCurrentTime
(maybe id take mlimit . drop start)
fmap (maybe id take mlimit . drop start)
# modifyMVar pc (parse'' t)
where
key = (from,input)
@@ -134,11 +139,15 @@ cpgfMain command (pgf,pc) =
do parses <- parse' input (from,concr) start mlimit
return $
showJSON [ makeObj ["from".=from,
"translations".=
[makeObj ["tree".=tree,
"prob".=prob,
"linearizations".=lin' tree tos]
| (tree,prob) <- parses]]]
"translations".= jsonParses parses]]
where
jsonParses = either bad good
where
bad err = [makeObj ["error".=err]]
good parses = [makeObj ["tree".=tree,
"prob".=prob,
"linearizations".=lin' tree tos]
| (tree,prob) <- parses]
from = maybe (missing "from") return =<< getLang "from"