msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

PGFService.hs: add output format option to the commands abstrtree, parsetree and alignment

Browse Source 
Supported output formats: gv, png, svg.
This commit is contained in:
hallgren
2012-03-08 11:25:15 +00:00
parent ed5de8335b
commit 0722f6f444
1 changed files with 46 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files

76
src/server/PGFService.hs
View File

@@ -48,29 +48,32 @@ cgiMain cache = handleErrors . handleCGIErrors $
cgiMain' :: Cache PGF -> FilePath -> CGI CGIResult cgiMain' :: Cache PGF -> FilePath -> CGI CGIResult
cgiMain' cache path = cgiMain' cache path =
do pgf <- liftIO $ readCache cache path do pgf <- liftIO $ readCache cache path
command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString)) (getInput "command") command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString))
(getInput "command")
pgfMain pgf command pgfMain pgf command
pgfMain :: PGF -> String -> CGI CGIResult pgfMain :: PGF -> String -> CGI CGIResult
pgfMain pgf command = do pgfMain pgf command =
case command of case command of
"parse" -> outputJSONP =<< doParse pgf `fmap` getText `ap` getCat `ap` getFrom "parse" -> outputJSONP =<< doParse pgf `fmap` getText `ap` getCat `ap` getFrom
"complete" -> outputJSONP =<< doComplete pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getLimit "complete" -> outputJSONP =<< doComplete pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getLimit
"linearize" -> outputJSONP =<< doLinearize pgf `fmap` getTree `ap` getTo "linearize" -> outputJSONP =<< doLinearize pgf `fmap` getTree `ap` getTo
"linearizeAll" -> outputJSONP =<< doLinearizes pgf `fmap` getTree `ap` getTo "linearizeAll" -> outputJSONP =<< doLinearizes pgf `fmap` getTree `ap` getTo
"random" -> getCat >>= \c -> getDepth >>= \dp -> getLimit >>= \l -> getTo >>= \to -> liftIO (doRandom pgf c dp l to) >>= outputJSONP "random" -> getCat >>= \c -> getDepth >>= \dp -> getLimit >>= \l -> getTo >>= \to -> liftIO (doRandom pgf c dp l to) >>= outputJSONP
"generate" -> outputJSONP =<< doGenerate pgf `fmap` getCat `ap` getDepth `ap` getLimit `ap` getTo "generate" -> outputJSONP =<< doGenerate pgf `fmap` getCat `ap` getDepth `ap` getLimit `ap` getTo
"translate" -> outputJSONP =<< doTranslate pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo "translate" -> outputJSONP =<< doTranslate pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo
"translategroup" -> outputJSONP =<< doTranslateGroup pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo "translategroup" -> outputJSONP =<< doTranslateGroup pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo
"grammar" -> outputJSONP =<< doGrammar pgf `fmap` requestAcceptLanguage "grammar" -> outputJSONP =<< doGrammar pgf `fmap` requestAcceptLanguage
"abstrtree" -> outputPNG =<< liftIO . doGraphvizAbstrTree pgf =<< getTree "abstrtree" -> outputGraphviz . abstrTree pgf =<< getTree
"parsetree" -> getTree >>= \t -> getFrom >>= \(Just l) -> liftIO (doGraphvizParseTree pgf l t) >>= outputPNG "alignment" -> outputGraphviz . alignment pgf =<< getTree
"alignment" -> getTree >>= liftIO . doGraphvizAlignment pgf >>= outputPNG "parsetree" -> do t <- getTree
"browse" -> outputHTML =<< doBrowse pgf `fmap` getId `ap` getCSSClass `ap` getHRef Just l <- getFrom
"external" -> do cmd <- getInput "external" outputGraphviz (parseTree pgf l t)
input <- getText "browse" -> outputHTML =<< doBrowse pgf `fmap` getId `ap` getCSSClass `ap` getHRef
doExternal cmd input "external" -> do cmd <- getInput "external"
_ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command] input <- getText
doExternal cmd input
_ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command]
where where
getText :: CGI String getText :: CGI String
getText = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input" getText = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
@@ -306,24 +309,37 @@ doGrammar pgf macc = showJSON $ makeObj
categories = [PGF.showCId cat | cat <- PGF.categories pgf] categories = [PGF.showCId cat | cat <- PGF.categories pgf]
functions = [PGF.showCId fun | fun <- PGF.functions pgf] functions = [PGF.showCId fun | fun <- PGF.functions pgf]
doGraphvizAbstrTree pgf tree = do outputGraphviz code =
pipeIt2graphviz $ PGF.graphvizAbstractTree pgf (True,True) tree do format <- maybe "png" id `fmap` getInput "format"
case format of
"gv" -> outputPlain code
_ -> outputFPS' format =<< liftIO (pipeIt2graphviz format code)
where
outputFPS' format bs =
do setHeader "Content-Type" (mimeType format)
outputFPS bs
doGraphvizParseTree pgf lang tree = do mimeType fmt =
pipeIt2graphviz $ PGF.graphvizParseTree pgf lang tree case fmt of
"png" -> "image/png"
"gif" -> "image/gif"
"svg" -> "image/svg+xml"
-- ...
_ -> "application/binary"
doGraphvizAlignment pgf tree = do abstrTree pgf tree = PGF.graphvizAbstractTree pgf (True,True) tree
pipeIt2graphviz $ PGF.graphvizAlignment pgf (PGF.languages pgf) tree parseTree pgf lang tree = PGF.graphvizParseTree pgf lang tree
alignment pgf tree = PGF.graphvizAlignment pgf (PGF.languages pgf) tree
pipeIt2graphviz :: String -> IO BS.ByteString pipeIt2graphviz :: String -> String -> IO BS.ByteString
pipeIt2graphviz code = do pipeIt2graphviz format code = do
(Just inh, Just outh, _, pid) <- (Just inh, Just outh, _, pid) <-
createProcess (proc "dot" ["-T","png"]) createProcess (proc "dot" ["-T",format])
{ std_in = CreatePipe, { std_in = CreatePipe,
std_out = CreatePipe, std_out = CreatePipe,
std_err = Inherit } std_err = Inherit }
hSetEncoding outh latin1 hSetBinaryMode outh True
hSetEncoding inh utf8 hSetEncoding inh utf8
-- fork off a thread to start consuming the output -- fork off a thread to start consuming the output