GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-23 18:02:54 -06:00
Code Issues Packages Projects Releases Wiki Activity

PGF web API: generalize the 'to' parameter to accept a list of languages

Browse Source 
Some commands (linearize, linearizeAll, random, generate, translate and
translategroup) by default produce output in all languages supported by the
grammar and the 'to' parameter could be used to restrict output to a single
language. Now you can restrict the output to a list of languages. Languages
should be separated by spaces.

Also removed an unnecessary LANGUAGE pragma and reduced code verbosity.
This commit is contained in:
hallgren
2013-03-13 15:25:28 +00:00
parent 7d1040ffb9
commit d4fc60f260
1 changed files with 94 additions and 92 deletions
Download Patch File Download Diff File Expand all files Collapse all files

164
src/server/PGFService.hs
View File

@@ -1,4 +1,3 @@
{-# LANGUAGE DeriveDataTypeable, CPP #-}
module PGFService(cgiMain,cgiMain',getPath, module PGFService(cgiMain,cgiMain',getPath,
logFile,stderrToFile, logFile,stderrToFile,
newPGFCache) where newPGFCache) where
@@ -11,7 +10,7 @@ import URLEncoding
import Network.CGI import Network.CGI
import Text.JSON import Text.JSON
import Text.PrettyPrint (render, text, (<+>)) import Text.PrettyPrint as PP(render, text, (<+>))
import qualified Codec.Binary.UTF8.String as UTF8 (decodeString) import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
@@ -60,44 +59,46 @@ cgiMain' cache path =
pgfMain :: String -> PGF -> CGI CGIResult pgfMain :: String -> PGF -> CGI CGIResult
pgfMain command pgf = pgfMain command pgf =
case command of case command of
"parse" -> outputJSONP =<< doParse pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getLimit "parse" -> out =<< doParse pgf # text % cat % from % limit
"complete" -> outputJSONP =<< doComplete pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getLimit "complete" -> out =<< doComplete pgf # text % cat % from % limit
"linearize" -> outputJSONP =<< doLinearize pgf `fmap` getTree `ap` getTo "linearize" -> out =<< doLinearize pgf # tree % to
"linearizeAll" -> outputJSONP =<< doLinearizes pgf `fmap` getTree `ap` getTo "linearizeAll" -> out =<< doLinearizes pgf # tree % to
"random" -> getCat >>= \c -> getDepth >>= \dp -> getLimit >>= \l -> getTo >>= \to -> liftIO (doRandom pgf c dp l to) >>= outputJSONP "random" -> cat >>= \c -> depth >>= \dp -> limit >>= \l -> to >>= \to -> liftIO (doRandom pgf c dp l to) >>= out
"generate" -> outputJSONP =<< doGenerate pgf `fmap` getCat `ap` getDepth `ap` getLimit `ap` getTo "generate" -> out =<< doGenerate pgf # cat % depth % limit % to
"translate" -> outputJSONP =<< doTranslate pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo `ap` getLimit "translate" -> out =<< doTranslate pgf # text % cat % from % to % limit
"translategroup" -> outputJSONP =<< doTranslateGroup pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo `ap` getLimit "translategroup" -> out =<< doTranslateGroup pgf # text % cat % from % to % limit
"grammar" -> outputJSONP =<< doGrammar pgf `fmap` requestAcceptLanguage "grammar" -> out =<< doGrammar pgf # requestAcceptLanguage
"abstrtree" -> outputGraphviz . abstrTree pgf =<< getTree "abstrtree" -> outputGraphviz . abstrTree pgf =<< tree
"alignment" -> outputGraphviz . alignment pgf =<< getTree "alignment" -> outputGraphviz . alignment pgf =<< tree
"parsetree" -> do t <- getTree "parsetree" -> do t <- tree
Just l <- getFrom Just l <- from
outputGraphviz (parseTree pgf l t) outputGraphviz (parseTree pgf l t)
"abstrjson" -> outputJSONP . jsonExpr =<< getTree "abstrjson" -> out . jsonExpr =<< tree
"browse" -> id =<< doBrowse pgf `fmap` getOptId `ap` getCSSClass `ap` getHRef `ap` getFormat "html" `ap` getIncludePrintNames "browse" -> join $ doBrowse pgf # optId % cssClass % href % format "html" % getIncludePrintNames
"external" -> do cmd <- getInput "external" "external" -> do cmd <- getInput "external"
input <- getText input <- text
doExternal cmd input doExternal cmd input
_ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command] _ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command]
where where
getText :: CGI String out = outputJSONP
getText = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
getTree :: CGI PGF.Tree text :: CGI String
getTree = do ms <- getInput "tree" text = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
tree :: CGI PGF.Tree
tree = do ms <- getInput "tree"
s <- maybe (throwCGIError 400 "No tree given" ["No tree given"]) return ms s <- maybe (throwCGIError 400 "No tree given" ["No tree given"]) return ms
t <- maybe (throwCGIError 400 "Bad tree" ["tree: " ++ s]) return (PGF.readExpr s) t <- maybe (throwCGIError 400 "Bad tree" ["tree: " ++ s]) return (PGF.readExpr s)
t <- either (\err -> throwCGIError 400 "Type incorrect tree" t <- either (\err -> throwCGIError 400 "Type incorrect tree"
["tree: " ++ PGF.showExpr [] t ["tree: " ++ PGF.showExpr [] t
,render (text "error:" <+> PGF.ppTcError err) ,render (PP.text "error:" <+> PGF.ppTcError err)
]) ])
(return . fst) (return . fst)
(PGF.inferExpr pgf t) (PGF.inferExpr pgf t)
return t return t
getCat :: CGI (Maybe PGF.Type) cat :: CGI (Maybe PGF.Type)
getCat = cat =
do mcat <- getInput "cat" do mcat <- getInput "cat"
case mcat of case mcat of
Nothing -> return Nothing Nothing -> return Nothing
@@ -106,51 +107,50 @@ pgfMain command pgf =
Nothing -> throwCGIError 400 "Bad category" ["Bad category: " ++ cat] Nothing -> throwCGIError 400 "Bad category" ["Bad category: " ++ cat]
Just typ -> return $ Just typ -- typecheck the category Just typ -> return $ Just typ -- typecheck the category
getFrom :: CGI (Maybe PGF.Language) optId :: CGI (Maybe PGF.CId)
getFrom = getLang "from" optId = maybe (return Nothing) rd =<< getInput "id"
getTo :: CGI (Maybe PGF.Language)
getTo = getLang "to"
getId :: CGI PGF.CId
getId = maybe errorMissingId return =<< getOptId
getOptId :: CGI (Maybe PGF.CId)
getOptId = maybe (return Nothing) rd =<< getInput "id"
where where
rd = maybe err (return . Just) . PGF.readCId rd = maybe err (return . Just) . PGF.readCId
err = throwCGIError 400 "Bad identifier" [] err = throwCGIError 400 "Bad identifier" []
getCSSClass :: CGI (Maybe String) cssClass, href :: CGI (Maybe String)
getCSSClass = getInput "css-class" cssClass = getInput "css-class"
href = getInput "href"
getHRef :: CGI (Maybe String) limit, depth :: CGI (Maybe Int)
getHRef = getInput "href" limit = readInput "limit"
depth = readInput "depth"
getLimit :: CGI (Maybe Int) from :: CGI (Maybe PGF.Language)
getLimit = readInput "limit" from = getLang "from"
getDepth :: CGI (Maybe Int) to :: CGI [PGF.Language]
getDepth = readInput "depth" to = getLangs "to"
getLangs :: String -> CGI [PGF.Language]
getLangs i = mapM readLang . maybe [] words =<< getInput i
getLang :: String -> CGI (Maybe PGF.Language) getLang :: String -> CGI (Maybe PGF.Language)
getLang i = getLang i =
do mlang <- getInput i do mlang <- getInput i
case mlang of case mlang of
Nothing -> return Nothing Just l@(_:_) -> Just # readLang l
Just "" -> return Nothing _ -> return Nothing
Just l -> case PGF.readLanguage l of
readLang :: String -> CGI PGF.Language
readLang l =
case PGF.readLanguage l of
Nothing -> throwCGIError 400 "Bad language" ["Bad language: " ++ l] Nothing -> throwCGIError 400 "Bad language" ["Bad language: " ++ l]
Just lang | lang `elem` PGF.languages pgf -> return $ Just lang Just lang | lang `elem` PGF.languages pgf -> return lang
| otherwise -> throwCGIError 400 "Unknown language" ["Unknown language: " ++ l] | otherwise -> throwCGIError 400 "Unknown language" ["Unknown language: " ++ l]
getIncludePrintNames :: CGI Bool getIncludePrintNames :: CGI Bool
getIncludePrintNames = maybe (return False) (\_->return True) =<< getInput "printnames" getIncludePrintNames = maybe False (const True) # getInput "printnames"
errorMissingId = throwCGIError 400 "Missing identifier" [] errorMissingId = throwCGIError 400 "Missing identifier" []
getFormat def = maybe def id `fmap` getInput "format" format def = maybe def id # getInput "format"
-- Hook for simple extensions of the PGF service -- Hook for simple extensions of the PGF service
doExternal Nothing input = throwCGIError 400 "Unknown external command" ["Unknown external command"] doExternal Nothing input = throwCGIError 400 "Unknown external command" ["Unknown external command"]
@@ -172,8 +172,8 @@ doExternal (Just cmd) input =
liftIO $ removeFile tmpfile2 liftIO $ removeFile tmpfile2
return r return r
doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> Maybe Int -> JSValue doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> JSValue
doTranslate pgf input mcat mfrom mto mlimit = doTranslate pgf input mcat mfrom tos mlimit =
showJSON showJSON
[makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po) [makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po)
| (from,po,bs) <- parse' pgf input mcat mfrom] | (from,po,bs) <- parse' pgf input mcat mfrom]
@@ -185,7 +185,7 @@ doTranslate pgf input mcat mfrom mto mlimit =
[makeObj ["tree".=tree, [makeObj ["tree".=tree,
"linearizations".= "linearizations".=
[makeObj ["to".=to, "text".=text, "brackets".=bs] [makeObj ["to".=to, "text".=text, "brackets".=bs]
| (to,text,bs)<- linearizeAndBind pgf mto tree]] | (to,text,bs)<- linearizeAndBind pgf tos tree]]
| tree <- maybe id take mlimit trees]] | tree <- maybe id take mlimit trees]]
PGF.ParseIncomplete -> ["incomplete".=True] PGF.ParseIncomplete -> ["incomplete".=True]
PGF.ParseFailed n -> ["parseFailed".=n] PGF.ParseFailed n -> ["parseFailed".=n]
@@ -196,8 +196,8 @@ jsonTypeErrors errs =
| (fid,err) <- errs]] | (fid,err) <- errs]]
-- used in phrasebook -- used in phrasebook
doTranslateGroup :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> Maybe Int -> JSValue doTranslateGroup :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> JSValue
doTranslateGroup pgf input mcat mfrom mto mlimit = doTranslateGroup pgf input mcat mfrom tos mlimit =
showJSON showJSON
[makeObj ["from".=langOnly (PGF.showLanguage from), [makeObj ["from".=langOnly (PGF.showLanguage from),
"to".=langOnly (PGF.showLanguage to), "to".=langOnly (PGF.showLanguage to),
@@ -207,7 +207,7 @@ doTranslateGroup pgf input mcat mfrom mto mlimit =
] ]
| |
(from,po,bs) <- parse' pgf input mcat mfrom, (from,po,bs) <- parse' pgf input mcat mfrom,
(to,output) <- groupResults [(t, linearize' pgf mto t) | t <- case po of {PGF.ParseOk ts -> maybe id take mlimit ts; _ -> []}] (to,output) <- groupResults [(t, linearize' pgf tos t) | t <- case po of {PGF.ParseOk ts -> maybe id take mlimit ts; _ -> []}]
] ]
where where
groupResults = Map.toList . foldr more Map.empty . start . collect groupResults = Map.toList . foldr more Map.empty . start . collect
@@ -273,34 +273,34 @@ doComplete pgf input mcat mfrom mlimit = showJSON
froms = maybe (PGF.languages pgf) (:[]) mfrom froms = maybe (PGF.languages pgf) (:[]) mfrom
cat = fromMaybe (PGF.startCat pgf) mcat cat = fromMaybe (PGF.startCat pgf) mcat
doLinearize :: PGF -> PGF.Tree -> Maybe PGF.Language -> JSValue doLinearize :: PGF -> PGF.Tree -> [PGF.Language] -> JSValue
doLinearize pgf tree mto = showJSON doLinearize pgf tree tos = showJSON
[makeObj ["to".=to, "text".=text,"brackets".=bs] [makeObj ["to".=to, "text".=text,"brackets".=bs]
| (to,text,bs) <- linearize' pgf mto tree] | (to,text,bs) <- linearize' pgf tos tree]
doLinearizes :: PGF -> PGF.Tree -> Maybe PGF.Language -> JSValue doLinearizes :: PGF -> PGF.Tree -> [PGF.Language] -> JSValue
doLinearizes pgf tree mto = showJSON doLinearizes pgf tree tos = showJSON
[makeObj ["to".=to, "texts".=texts] [makeObj ["to".=to, "texts".=texts]
| (to,texts) <- linearizes' pgf mto tree] | (to,texts) <- linearizes' pgf tos tree]
doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> Maybe PGF.Language -> IO JSValue doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> [PGF.Language] -> IO JSValue
doRandom pgf mcat mdepth mlimit mto = doRandom pgf mcat mdepth mlimit tos =
do g <- newStdGen do g <- newStdGen
let trees = PGF.generateRandomDepth g pgf cat (Just depth) let trees = PGF.generateRandomDepth g pgf cat (Just depth)
return $ showJSON return $ showJSON
[makeObj ["tree".=PGF.showExpr [] tree, [makeObj ["tree".=PGF.showExpr [] tree,
"linearizations".= doLinearizes pgf tree mto] "linearizations".= doLinearizes pgf tree tos]
| tree <- limit trees] | tree <- limit trees]
where cat = fromMaybe (PGF.startCat pgf) mcat where cat = fromMaybe (PGF.startCat pgf) mcat
limit = take (fromMaybe 1 mlimit) limit = take (fromMaybe 1 mlimit)
depth = fromMaybe 4 mdepth depth = fromMaybe 4 mdepth
doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> Maybe PGF.Language -> JSValue doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> [PGF.Language] -> JSValue
doGenerate pgf mcat mdepth mlimit mto = doGenerate pgf mcat mdepth mlimit tos =
showJSON [makeObj ["tree".=PGF.showExpr [] tree, showJSON [makeObj ["tree".=PGF.showExpr [] tree,
"linearizations".= "linearizations".=
[makeObj ["to".=to, "text".=text] [makeObj ["to".=to, "text".=text]
| (to,text,bs) <- linearize' pgf mto tree]] | (to,text,bs) <- linearize' pgf tos tree]]
| tree <- limit trees] | tree <- limit trees]
where where
trees = PGF.generateAllDepth pgf cat (Just depth) trees = PGF.generateAllDepth pgf cat (Just depth)
@@ -325,13 +325,13 @@ doGrammar pgf macc = showJSON $ makeObj
functions = [PGF.showCId fun | fun <- PGF.functions pgf] functions = [PGF.showCId fun | fun <- PGF.functions pgf]
outputGraphviz code = outputGraphviz code =
do format <- getFormat "png" do fmt <- format "png"
case format of case fmt of
"gv" -> outputPlain code "gv" -> outputPlain code
_ -> outputFPS' format =<< liftIO (pipeIt2graphviz format code) _ -> outputFPS' fmt =<< liftIO (pipeIt2graphviz fmt code)
where where
outputFPS' format bs = outputFPS' fmt bs =
do setHeader "Content-Type" (mimeType format) do setHeader "Content-Type" (mimeType fmt)
outputFPS bs outputFPS bs
mimeType fmt = mimeType fmt =
@@ -347,9 +347,9 @@ parseTree pgf lang tree = PGF.graphvizParseTree pgf lang PGF.graphvizDefaults tr
alignment pgf tree = PGF.graphvizAlignment pgf (PGF.languages pgf) tree alignment pgf tree = PGF.graphvizAlignment pgf (PGF.languages pgf) tree
pipeIt2graphviz :: String -> String -> IO BS.ByteString pipeIt2graphviz :: String -> String -> IO BS.ByteString
pipeIt2graphviz format code = do pipeIt2graphviz fmt code = do
(Just inh, Just outh, _, pid) <- (Just inh, Just outh, _, pid) <-
createProcess (proc "dot" ["-T",format]) createProcess (proc "dot" ["-T",fmt])
{ std_in = CreatePipe, { std_in = CreatePipe,
std_out = CreatePipe, std_out = CreatePipe,
std_err = Inherit } std_err = Inherit }
@@ -541,24 +541,24 @@ complete' pgf from typ mlimit input =
Left es -> (ps,w:ws) Left es -> (ps,w:ws)
Right ps -> loop ps ws Right ps -> loop ps ws
linearize' :: PGF -> Maybe PGF.Language -> PGF.Tree -> [(PGF.Language,String,PGF.BracketedString)] linearize' :: PGF -> [PGF.Language] -> PGF.Tree -> [(PGF.Language,String,PGF.BracketedString)]
linearize' pgf mto tree = linearize' pgf to tree =
[(to,s,bs) | to<-langs, [(to,s,bs) | to<-langs,
let bs = PGF.bracketedLinearize pgf to (transfer to tree) let bs = PGF.bracketedLinearize pgf to (transfer to tree)
s = unwords $ PGF.flattenBracketedString bs] s = unwords $ PGF.flattenBracketedString bs]
where where
langs = maybe (PGF.languages pgf) (:[]) mto langs = if null to then PGF.languages pgf else to
transfer lang = if "LaTeX" `isSuffixOf` show lang transfer lang = if "LaTeX" `isSuffixOf` show lang
then fold -- OpenMath LaTeX transfer then fold -- OpenMath LaTeX transfer
else id else id
-- all variants and their forms -- all variants and their forms
linearizes' :: PGF -> Maybe PGF.Language -> PGF.Tree -> [(PGF.Language,[String])] linearizes' :: PGF -> [PGF.Language] -> PGF.Tree -> [(PGF.Language,[String])]
linearizes' pgf mto tree = linearizes' pgf tos tree =
[(to,lins to (transfer to tree)) | to <- langs] [(to,lins to (transfer to tree)) | to <- langs]
where where
langs = maybe (PGF.languages pgf) (:[]) mto langs = if null tos then PGF.languages pgf else tos
lins to = nub . concatMap (map snd) . PGF.tabularLinearizes pgf to lins to = nub . concatMap (map snd) . PGF.tabularLinearizes pgf to
linearizeAndBind pgf mto t = linearizeAndBind pgf mto t =
@@ -585,6 +585,8 @@ langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languag
-- * General utilities -- * General utilities
f .= v = (f,showJSON v) f .= v = (f,showJSON v)
f # x = fmap f x
f % x = ap f x
--cleanFilePath :: FilePath -> FilePath --cleanFilePath :: FilePath -> FilePath
--cleanFilePath = takeFileName --cleanFilePath = takeFileName