PGF service & minibar: only show dependency diagrams if the labels are known

+ The PGF service now reads and caches dependency label configuration files.
+ The grammar info returned by command=grammar has a new boolean field 
  'hasDependencyLabels' to indicate if dependency labels were found for
  the grammar. Also, command=deptree will now fail if no labels are present.
+ The minibar only shows word dependency trees if labels are present.
+ Also changed the type of getDepLabels from [String] -> Labels to
  String -> Labels, since all uses were in the form "getDepLabels . lines".

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

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

src/runtime/haskell/PGF.hs

@@ -131,7 +131,7 @@ module PGF(
            graphvizDefaults,
            conlls2latexDoc,
            -- extra:
-           getDepLabels,
+           Labels, getDepLabels,
  
            -- * Probabilities
            Probabilities,

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 :: String -> Labels
-getDepLabels ss = Map.fromList [(mkCId f,ls) | f:ls <- map words ss]
+getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map words (lines s)]
 
 -- the old function, without dependencies
 graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String

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))
+                      return $ Caches pgfCache lblCache (cCache,qsem)
-flushPGFCache (c1,(c2,_)) = flushCache c1 >> flushCache c2
+flushPGFCache c = do flushCache (pgfCache c)
-listPGFCache (c1,(c2,_)) = (,) # listCache c1 % listCache c2
+                     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,())
+                   lblCache <- newCache' (fmap PGF.getDepLabels . readFile)
-flushPGFCache (c1,_) = flushCache c1
+                   return $ Caches pgfCache lblCache
-listPGFCache (c1,_) = (,) # listCache c1 % return []
+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
+         "download" -> outputBinary =<< getFile BS.readFile path
-         'c':'-':_  ->
+         '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
+    cpgfMain (snd (cpgfCache cache)) command
-                      =<< getFile (readCache' (fst (snd cache))) path
+       =<< 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 :: Cache Labels -> FilePath -> String -> PGF -> CGI CGIResult
-pgfMain path command (t,pgf) =
+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 :: (UTCTime,PGF) -> Either IOError (UTCTime,l) -> Maybe (Accept Language) -> CGI CGIResult
-doGrammar t pgf macc = showJSON $ makeObj
+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 =
+doDepTree lc path pgf fmt lang tree =
-  do lbls <- either (const Nothing) Just # liftIO (tryIOError readDepLabels)
+  do (_,lbls) <- liftIO $ getLabels lc path pgf
-     let vis = PGF.graphvizDependencyTree fmt False lbls Nothing pgf lang tree
+     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"
+    dir = takeDirectory path
-    readDepLabels = PGF.getDepLabels . lines # readFile labelsPath
+  --path1 = dir</> ...labels flag from abstract syntax...
+    path2 = dir</>PGF.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

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);