GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-19 09:49:33 -06:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
+ 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".
This commit is contained in:
hallgren
2016-06-09 13:12:14 +00:00
parent 617624e2a8
commit 096b4cfcee
6 changed files with 61 additions and 44 deletions
Download Patch File Download Diff File Expand all files Collapse all files

83
src/server/PGFService.hs
View File

@@ -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 = 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