diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index cf1262f35..ea62ba69a 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -551,7 +551,7 @@ pgfCommands = Map.fromList [ let outp = valStrOpts "output" "dot" opts mlab <- case file of "" -> return Nothing - _ -> (Just . getDepLabels . lines) `fmap` restricted (readFile file) + _ -> (Just . getDepLabels) `fmap` restricted (readFile file) let lang = optLang pgf opts let grphs = map (graphvizDependencyTree outp debug mlab Nothing pgf lang) es if isOpt "conll2latex" opts @@ -616,7 +616,7 @@ pgfCommands = Map.fromList [ let depfile = valStrOpts "file" "" opts mlab <- case depfile of "" -> return Nothing - _ -> (Just . getDepLabels . lines) `fmap` restricted (readFile depfile) + _ -> (Just . getDepLabels) `fmap` restricted (readFile depfile) let grphs = map (graphvizParseTreeDep mlab pgf lang gvOptions) es if isFlag "view" opts || isFlag "format" opts then do diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs index 3a193cc33..d5c84b87c 100644 --- a/src/compiler/GF/Server.hs +++ b/src/compiler/GF/Server.hs @@ -174,7 +174,7 @@ handle logLn documentroot state0 cache execute1 stateVar (_ ,_ ,".pgf") -> do --debug $ "PGF service: "++path wrapCGI $ PS.cgiMain' cache path (dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs) - (dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir (fst cache) + (dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir (PS.pgfCache cache) _ -> serveStaticFile rpath path where path = translatePath rpath _ -> return $ resp400 upath diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index bda3919be..293aec0fd 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -131,7 +131,7 @@ module PGF( graphvizDefaults, conlls2latexDoc, -- extra: - getDepLabels, + Labels, getDepLabels, -- * Probabilities Probabilities, diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs index 29e8d3de2..8257230e1 100644 --- a/src/runtime/haskell/PGF/VisualizeTree.hs +++ b/src/runtime/haskell/PGF/VisualizeTree.hs @@ -16,7 +16,7 @@ module PGF.VisualizeTree , graphvizParseTree , graphvizParseTreeDep , graphvizDependencyTree - , getDepLabels + , Labels, getDepLabels , graphvizBracketedString , graphvizAlignment , gizaAlignment @@ -232,8 +232,8 @@ graphvizDependencyTree format debug mlab ms pgf lang t = -- | Prepare lines obtained from a configuration file for labels for -- use with 'graphvizDependencyTree'. Format per line /fun/ /label/@*@. -getDepLabels :: [String] -> Labels -getDepLabels ss = Map.fromList [(mkCId f,ls) | f:ls <- map words ss] +getDepLabels :: String -> Labels +getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map words (lines s)] -- the old function, without dependencies graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 1f75a8904..502689f95 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} module PGFService(cgiMain,cgiMain',getPath, logFile,stderrToFile, - newPGFCache,flushPGFCache,listPGFCache) where + Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where -import PGF (PGF) +import PGF (PGF,Labels) import qualified PGF import PGF.Lexing import Cache @@ -46,9 +46,9 @@ import System.Random import System.Process import System.Exit import System.IO -import System.IO.Error(isDoesNotExistError,tryIOError) +import System.IO.Error(isDoesNotExistError) import System.Directory(removeFile) -import System.FilePath(dropExtension,(<.>)) +import System.FilePath(dropExtension,takeDirectory,(),(<.>)) import System.Mem(performGC) import Fold(fold) -- transfer function for OpenMath LaTeX @@ -61,26 +61,32 @@ logFile :: FilePath logFile = "pgf-error.log" #ifdef C_RUNTIME -type Caches = (Cache PGF,(Cache (C.PGF,({-MVar ParseCache-})),QSem)) +data Caches = Caches { pgfCache::Cache PGF, + labelsCache::Cache Labels, + cpgfCache::(Cache (C.PGF,({-MVar ParseCache-})),QSem) } --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 jobs = do pgfCache <- newCache' PGF.readPGF + lblCache <- newCache' (fmap PGF.getDepLabels . 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 (pgfCache,(cCache,qsem)) -flushPGFCache (c1,(c2,_)) = flushCache c1 >> flushCache c2 -listPGFCache (c1,(c2,_)) = (,) # listCache c1 % listCache c2 + return $ Caches pgfCache lblCache (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 -type Caches = (Cache PGF,()) +data Caches = Caches { pgfCache::Cache PGF, labelsCache::Cache Labels} newPGFCache _ = do pgfCache <- newCache' PGF.readPGF - return (pgfCache,()) -flushPGFCache (c1,_) = flushCache c1 -listPGFCache (c1,_) = (,) # listCache c1 % return [] + lblCache <- newCache' (fmap PGF.getDepLabels . readFile) + return $ Caches pgfCache lblCache +flushPGFCache c = flushCache (pgfCache c) +listPGFCache c = (,) # listCache (pgfCache c) % return [] #endif newCache' rd = do c <- newCache rd @@ -105,15 +111,21 @@ cgiMain' cache path = do command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString)) (getInput "command") case command of - "download" -> outputBinary =<< getFile BS.readFile path - 'c':'-':_ -> + "download" -> outputBinary =<< getFile BS.readFile path + 'c':'-':_ -> optionalCpgfMain cache path command + _ -> do tpgf <- getFile (readCache' (pgfCache cache)) path + pgfMain (labelsCache cache) path command tpgf + +optionalCpgfMain cache path command = #ifdef C_RUNTIME - cpgfMain (snd (snd cache)) command - =<< getFile (readCache' (fst (snd cache))) path + cpgfMain (snd (cpgfCache cache)) command + =<< getFile (readCache' (fst (cpgfCache cache))) path #else - serverError "Server configured without C run-time support" "" + serverError "Server configured without C run-time support" "" + +serverError = throw 500 + #endif - _ -> pgfMain path command =<< getFile (readCache' (fst cache)) path getFile get path = either failed return =<< liftIO (E.try (get path)) @@ -312,10 +324,6 @@ instance ToATree C.Expr where showTree = show toATree = cToATree -#else - -serverError = throw 500 - #endif -------------------------------------------------------------------------------- @@ -381,8 +389,8 @@ unlexerH = maybe (return doBind) unlexerfun =<< getInput "unlexer" -------------------------------------------------------------------------------- -- * Haskell run-time functionality ---pgfMain :: FilePath -> String -> PGF -> CGI CGIResult -pgfMain path command (t,pgf) = +--pgfMain :: Cache Labels -> FilePath -> String -> PGF -> CGI CGIResult +pgfMain lc path command tpgf@(t,pgf) = case command of "parse" -> o =<< doParse pgf # input % cat % limit % treeopts "complete" -> o =<< doComplete pgf # input % cat % limit % full @@ -394,11 +402,13 @@ pgfMain path command (t,pgf) = "translate" -> o =<< doTranslate pgf # input % cat %to%limit%treeopts "translategroup" -> o =<< doTranslateGroup pgf # input % cat % to % limit "lookupmorpho" -> o =<< doLookupMorpho pgf # from1 % textInput - "grammar" -> o =<< doGrammar t pgf # requestAcceptLanguage + "grammar" -> join $ doGrammar tpgf + # liftIO (E.try (getLabels lc 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 path pgf # format "dot" % to1 % tree + "deptree" -> join $ doDepTree lc 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" @@ -740,16 +750,18 @@ doGenerate pgf mcat mdepth mlimit tos = limit = take (fromMaybe 1 mlimit) depth = fromMaybe 4 mdepth -doGrammar :: UTCTime -> PGF -> Maybe (Accept Language) -> JSValue -doGrammar t pgf macc = showJSON $ makeObj +doGrammar :: (UTCTime,PGF) -> Either IOError (UTCTime,l) -> Maybe (Accept Language) -> CGI CGIResult +doGrammar (t1,pgf) elbls macc = out t $ showJSON $ makeObj ["name".=PGF.abstractName pgf, "lastmodified".=show t, + "hasDependencyLabels".=either (const False) (const True) elbls, "userLanguage".=selectLanguage pgf macc, "startcat".=PGF.showType [] (PGF.startCat pgf), "categories".=categories, "functions".=functions, "languages".=languages] where + t = either (const t1) (max t1 . fst) elbls languages = [makeObj ["name".= l, "languageCode".= fromMaybe "" (PGF.languageCode pgf l)] @@ -778,17 +790,22 @@ abstrTree pgf opts tree = PGF.graphvizAbstractTree pgf opts' tree parseTree pgf lang opts tree = PGF.graphvizParseTree pgf lang opts tree -doDepTree path pgf fmt lang tree = - do lbls <- either (const Nothing) Just # liftIO (tryIOError readDepLabels) - let vis = PGF.graphvizDependencyTree fmt False lbls Nothing pgf lang tree +doDepTree lc path pgf fmt lang tree = + do (_,lbls) <- liftIO $ getLabels lc path pgf + let vis = PGF.graphvizDependencyTree fmt False (Just lbls) () pgf lang tree if fmt `elem` ["png","gif","gv"] then outputGraphviz vis else if fmt=="svg" then outputText "image/svg+xml" vis else outputPlain vis + +getLabels lc path pgf = + msum [readCache' lc path | path<-[{-path1,-}path2,path3]] where - labelsPath = dropExtension path <.> "labels" - readDepLabels = PGF.getDepLabels . lines # readFile labelsPath + dir = takeDirectory path + --path1 = dir ...labels flag from abstract syntax... + path2 = dirPGF.showCId (PGF.abstractName pgf)<.>"labels" + path3 = dropExtension path <.> "labels" alignment pgf tree (tos,unlex) = PGF.graphvizAlignment pgf tos' tree where tos' = if null tos then PGF.languages pgf else tos diff --git a/src/www/minibar/minibar_translations.js b/src/www/minibar/minibar_translations.js index 01b4d21dd..66bd5bd18 100644 --- a/src/www/minibar/minibar_translations.js +++ b/src/www/minibar/minibar_translations.js @@ -135,7 +135,7 @@ Translations.prototype.show_translations=function(translationResults) { var ts = text_speech(langcode,to,txt,lin) var as = wrap("span", self.options.show_trees - ? [self.parsetree_button(tree,to),text(" "),ts] + ? [self.parsetree_button(tree,to,self.grammar),text(" "),ts] : [ts]) as.active=txt as.swap=ts @@ -225,7 +225,7 @@ Translations.prototype.show_translations=function(translationResults) { var hdr=title("Switch input language to "+langcode, button(langcode,act(lin[i]))) //hdr.disabled=lin[i].to==current.from - var btn=parsetree_button(t.tree,lin[i].to) + var btn=parsetree_button(t.tree,lin[i].to,grammar) tbody.appendChild( tr([th(hdr),show_lin(langcode,lin[i],t.tree)])); } @@ -288,14 +288,14 @@ Translations.prototype.alignment_button=function(abs,all,toLangs) { return i; } -Translations.prototype.parsetree_button=function(abs,lang) { +Translations.prototype.parsetree_button=function(abs,lang,grammar) { var f=this.options.tree_img_format; var img=this.server.current_grammar_url +"?command=parsetree&format="+f+"&nodep=true&nodefont=arial" +"&from="+lang+"&tree="+encodeURIComponent(abs); var img_nofun=img+"&nofun=true" var help="Click again to display parse tree. Click again to show function names." - if(f=="svg") { + if(f=="svg" && grammar.hasDependencyLabels) { var depimg=this.server.current_grammar_url +"?command=deptree&format=svg&to="+lang +"&tree="+encodeURIComponent(abs);