GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-30 23:02:50 -06:00
Code Issues Packages Projects Releases Wiki 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 bd892b8a1d
commit 4018073bdb
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 #ifdef C_RUNTIME
type Caches = (Cache PGF,Cache (C.PGF,MVar ParseCache)) 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 newPGFCache = do pgfCache <- newCache PGF.readPGF
cCache <- newCache $ \ path -> do pgf <- C.readPGF path cCache <- newCache $ \ path -> do pgf <- C.readPGF path
pc <- newMVar Map.empty pc <- newMVar Map.empty
@@ -106,15 +108,18 @@ cpgfMain command (pgf,pc) =
languages = [makeObj ["name".= l] | (l,_)<-Map.toList (C.languages pgf)] languages = [makeObj ["name".= l] | (l,_)<-Map.toList (C.languages pgf)]
parse input (from,concr) start mlimit trie = parse input (from,concr) start mlimit trie =
do trees <- parse' input (from,concr) start mlimit do r <- parse' input (from,concr) start mlimit
return $ showJSON [makeObj ("from".=from:"trees".=map tp trees :[])] return $ showJSON [makeObj ("from".=from:jsonParseResult r)]
-- :addTrie trie trees
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 = parse' input (from,concr) start mlimit =
liftIO $ do t <- getCurrentTime liftIO $ do t <- getCurrentTime
(maybe id take mlimit . drop start) fmap (maybe id take mlimit . drop start)
# modifyMVar pc (parse'' t) # modifyMVar pc (parse'' t)
where where
key = (from,input) key = (from,input)
@@ -134,11 +139,15 @@ cpgfMain command (pgf,pc) =
do parses <- parse' input (from,concr) start mlimit do parses <- parse' input (from,concr) start mlimit
return $ return $
showJSON [ makeObj ["from".=from, showJSON [ makeObj ["from".=from,
"translations".= "translations".= jsonParses parses]]
[makeObj ["tree".=tree, where
"prob".=prob, jsonParses = either bad good
"linearizations".=lin' tree tos] where
| (tree,prob) <- parses]]] 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" from = maybe (missing "from") return =<< getLang "from"