From d620c62d0b883a507afd75584c06e8fad6ae32ab Mon Sep 17 00:00:00 2001 From: hallgren Date: Fri, 5 May 2017 14:01:02 +0000 Subject: [PATCH] PGFService: add CncLabels support to command=deptree CncLabels are read from a file in the same directory as the PGF file and with the same name as the concrete syntax + extension .labels, e.g. ResourceDemo.pgf would use labels from ResouceDemo.labels (abslabels) ResouceDemoEng.labels (clclabels) --- src/server/PGFService.hs | 47 ++++++++++++++++++++++++++++++---------- 1 file changed, 35 insertions(+), 12 deletions(-) diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index f12ad75fb..a63af3dd8 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -3,7 +3,7 @@ module PGFService(cgiMain,cgiMain',getPath, logFile,stderrToFile, Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where -import PGF (PGF,Labels) +import PGF (PGF,Labels,CncLabels) import qualified PGF import PGF.Lexing import Cache @@ -63,6 +63,7 @@ logFile = "pgf-error.log" #ifdef C_RUNTIME data Caches = Caches { pgfCache::Cache PGF, labelsCache::Cache Labels, + cncLabelsCache::Cache CncLabels, cpgfCache::(Cache (C.PGF,({-MVar ParseCache-})),QSem) } --type Caches = (Cache PGF,Cache (C.PGF,({-MVar ParseCache-}))) --type ParseCache = Map.Map (String,String) (ParseResult,UTCTime) @@ -70,27 +71,33 @@ data Caches = Caches { pgfCache::Cache PGF, newPGFCache jobs = do pgfCache <- newCache' PGF.readPGF lblCache <- newCache' (fmap PGF.getDepLabels . readFile) + clblCache <- newCache'(fmap PGF.getCncDepLabels .readFile) let n = maybe 4 id jobs qsem <- newQSem n cCache <- newCache' $ \ path -> do pgf <- C.readPGF path --pc <- newMVar Map.empty return (pgf,({-pc-})) - return $ Caches pgfCache lblCache (cCache,qsem) + return $ Caches pgfCache lblCache clblCache (cCache,qsem) flushPGFCache c = do flushCache (pgfCache c) flushCache (labelsCache c) flushCache (fst (cpgfCache c)) listPGFCache c = (,) # listCache (pgfCache c) % listCache (fst (cpgfCache c)) #else -data Caches = Caches { pgfCache::Cache PGF, labelsCache::Cache Labels} +data Caches = Caches { pgfCache::Cache PGF, + labelsCache::Cache Labels, + cncLabelsCache::Cache CncLabels } newPGFCache _ = do pgfCache <- newCache' PGF.readPGF lblCache <- newCache' (fmap PGF.getDepLabels . readFile) - return $ Caches pgfCache lblCache + clblCache <- newCache'(fmap PGF.getCncDepLabels .readFile) + return $ Caches pgfCache lblCache clblCache flushPGFCache c = flushCache (pgfCache c) listPGFCache :: Caches -> IO ([(FilePath,UTCTime)],[(FilePath,UTCTime)]) listPGFCache c = (,) # listCache (pgfCache c) % return [] #endif +labelsCaches c = (labelsCache c,cncLabelsCache c) + newCache' rd = do c <- newCache rd forkIO $ forever $ clean c return c @@ -116,7 +123,7 @@ cgiMain' cache path = "download" -> outputBinary =<< getFile BS.readFile path 'c':'-':_ -> optionalCpgfMain cache path command _ -> do tpgf <- getFile (readCache' (pgfCache cache)) path - pgfMain (labelsCache cache) path command tpgf + pgfMain (labelsCaches cache) path command tpgf optionalCpgfMain cache path command = #ifdef C_RUNTIME @@ -392,7 +399,7 @@ unlexerH = maybe (return doBind) unlexerfun =<< getInput "unlexer" -- * Haskell run-time functionality --pgfMain :: Cache Labels -> FilePath -> String -> PGF -> CGI CGIResult -pgfMain lc path command tpgf@(t,pgf) = +pgfMain lcs@(alc,clc) path command tpgf@(t,pgf) = case command of "parse" -> o =<< doParse pgf # input % cat % limit % treeopts "complete" -> o =<< doComplete pgf # input % cat % limit % full @@ -405,12 +412,12 @@ pgfMain lc path command tpgf@(t,pgf) = "translategroup" -> o =<< doTranslateGroup pgf # input % cat % to % limit "lookupmorpho" -> o =<< doLookupMorpho pgf # from1 % textInput "grammar" -> join $ doGrammar tpgf - # liftIO (E.try (getLabels lc path pgf)) - % requestAcceptLanguage + # liftIO (E.try (getLabels alc path pgf)) + % requestAcceptLanguage "abstrtree" -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree "alignment" -> outputGraphviz =<< alignment pgf # tree % to "parsetree" -> outputGraphviz =<< parseTree pgf # from1 % graphvizOptions % tree - "deptree" -> join $ doDepTree lc path pgf # format "dot" % to1 % tree + "deptree" -> join $ doDepTree lcs path pgf # format "dot" % to1 % tree "abstrjson" -> o . jsonExpr =<< tree "browse" -> join $ doBrowse pgf # optId % cssClass % href % format "html" % getIncludePrintNames "external" -> do cmd <- getInput "external" @@ -792,9 +799,10 @@ abstrTree pgf opts tree = PGF.graphvizAbstractTree pgf opts' tree parseTree pgf lang opts tree = PGF.graphvizParseTree pgf lang opts tree -doDepTree lc path pgf fmt lang tree = - do (_,lbls) <- liftIO $ getLabels lc path pgf - let vis = PGF.graphvizDependencyTree fmt False (Just lbls) Nothing pgf lang tree ---- TODO: CncLabels +doDepTree (alc,clc) path pgf fmt lang tree = + do (_,lbls) <- liftIO $ getLabels alc path pgf + clbls <- liftIO $ getCncLabels clc path pgf lang + let vis = PGF.graphvizDependencyTree fmt False (Just lbls) clbls pgf lang tree if fmt `elem` ["png","gif","gv"] then outputGraphviz vis else if fmt=="svg" @@ -809,6 +817,21 @@ getLabels lc path pgf = path2 = dirPGF.showCId (PGF.abstractName pgf)<.>"labels" path3 = dropExtension path <.> "labels" +getCncLabels lc path pgf lang = + either fail ok =<< tryIO (readCache lc path2) + where + ok ls = do logError ("Found "++show (length ls)++" CncLabels for "++show lang++" in "++path2) + return (Just ls) + fail _ = do logError ("No CncLabels for "++show lang++" in "++path2) + return Nothing + dir = takeDirectory path + --path1 = dir ...labels flag from concrete syntax... + path2 = dirPGF.showCId lang<.>"labels" + --path3 = ... + +tryIO :: IO a -> IO (Either IOError a) +tryIO = E.try + alignment pgf tree (tos,unlex) = PGF.graphvizAlignment pgf tos' tree where tos' = if null tos then PGF.languages pgf else tos