summaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/PGFService.hs190
1 files changed, 96 insertions, 94 deletions
diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index b934717e6..ca7d8d310 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveDataTypeable, CPP #-}
module PGFService(cgiMain,cgiMain',getPath,
logFile,stderrToFile,
newPGFCache) where
@@ -11,7 +10,7 @@ import URLEncoding
import Network.CGI
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 Data.ByteString.Lazy as BS
@@ -60,44 +59,46 @@ cgiMain' cache path =
pgfMain :: String -> PGF -> CGI CGIResult
pgfMain command pgf =
case command of
- "parse" -> outputJSONP =<< doParse 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
- "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
- "generate" -> outputJSONP =<< doGenerate pgf `fmap` getCat `ap` getDepth `ap` getLimit `ap` getTo
- "translate" -> outputJSONP =<< doTranslate pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo `ap` getLimit
- "translategroup" -> outputJSONP =<< doTranslateGroup pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo `ap` getLimit
- "grammar" -> outputJSONP =<< doGrammar pgf `fmap` requestAcceptLanguage
- "abstrtree" -> outputGraphviz . abstrTree pgf =<< getTree
- "alignment" -> outputGraphviz . alignment pgf =<< getTree
- "parsetree" -> do t <- getTree
- Just l <- getFrom
+ "parse" -> out =<< doParse pgf # text % cat % from % limit
+ "complete" -> out =<< doComplete pgf # text % cat % from % limit
+ "linearize" -> out =<< doLinearize pgf # tree % to
+ "linearizeAll" -> out =<< doLinearizes pgf # tree % to
+ "random" -> cat >>= \c -> depth >>= \dp -> limit >>= \l -> to >>= \to -> liftIO (doRandom pgf c dp l to) >>= out
+ "generate" -> out =<< doGenerate pgf # cat % depth % limit % to
+ "translate" -> out =<< doTranslate pgf # text % cat % from % to % limit
+ "translategroup" -> out =<< doTranslateGroup pgf # text % cat % from % to % limit
+ "grammar" -> out =<< doGrammar pgf # requestAcceptLanguage
+ "abstrtree" -> outputGraphviz . abstrTree pgf =<< tree
+ "alignment" -> outputGraphviz . alignment pgf =<< tree
+ "parsetree" -> do t <- tree
+ Just l <- from
outputGraphviz (parseTree pgf l t)
- "abstrjson" -> outputJSONP . jsonExpr =<< getTree
- "browse" -> id =<< doBrowse pgf `fmap` getOptId `ap` getCSSClass `ap` getHRef `ap` getFormat "html" `ap` getIncludePrintNames
+ "abstrjson" -> out . jsonExpr =<< tree
+ "browse" -> join $ doBrowse pgf # optId % cssClass % href % format "html" % getIncludePrintNames
"external" -> do cmd <- getInput "external"
- input <- getText
+ input <- text
doExternal cmd input
_ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command]
where
- getText :: CGI String
- getText = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
-
- getTree :: CGI PGF.Tree
- getTree = do ms <- getInput "tree"
- 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 <- either (\err -> throwCGIError 400 "Type incorrect tree"
- ["tree: " ++ PGF.showExpr [] t
- ,render (text "error:" <+> PGF.ppTcError err)
- ])
- (return . fst)
- (PGF.inferExpr pgf t)
- return t
-
- getCat :: CGI (Maybe PGF.Type)
- getCat =
+ out = outputJSONP
+
+ text :: CGI String
+ 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
+ t <- maybe (throwCGIError 400 "Bad tree" ["tree: " ++ s]) return (PGF.readExpr s)
+ t <- either (\err -> throwCGIError 400 "Type incorrect tree"
+ ["tree: " ++ PGF.showExpr [] t
+ ,render (PP.text "error:" <+> PGF.ppTcError err)
+ ])
+ (return . fst)
+ (PGF.inferExpr pgf t)
+ return t
+
+ cat :: CGI (Maybe PGF.Type)
+ cat =
do mcat <- getInput "cat"
case mcat of
Nothing -> return Nothing
@@ -106,51 +107,50 @@ pgfMain command pgf =
Nothing -> throwCGIError 400 "Bad category" ["Bad category: " ++ cat]
Just typ -> return $ Just typ -- typecheck the category
- getFrom :: CGI (Maybe PGF.Language)
- getFrom = getLang "from"
-
- 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"
+ optId :: CGI (Maybe PGF.CId)
+ optId = maybe (return Nothing) rd =<< getInput "id"
where
rd = maybe err (return . Just) . PGF.readCId
err = throwCGIError 400 "Bad identifier" []
- getCSSClass :: CGI (Maybe String)
- getCSSClass = getInput "css-class"
+ cssClass, href :: CGI (Maybe String)
+ cssClass = getInput "css-class"
+ href = getInput "href"
- getHRef :: CGI (Maybe String)
- getHRef = getInput "href"
+ limit, depth :: CGI (Maybe Int)
+ limit = readInput "limit"
+ depth = readInput "depth"
- getLimit :: CGI (Maybe Int)
- getLimit = readInput "limit"
+ from :: CGI (Maybe PGF.Language)
+ from = getLang "from"
- getDepth :: CGI (Maybe Int)
- getDepth = readInput "depth"
+ to :: CGI [PGF.Language]
+ to = getLangs "to"
+
+ getLangs :: String -> CGI [PGF.Language]
+ getLangs i = mapM readLang . maybe [] words =<< getInput i
getLang :: String -> CGI (Maybe PGF.Language)
- getLang i =
+ getLang i =
do mlang <- getInput i
case mlang of
- Nothing -> return Nothing
- Just "" -> return Nothing
- Just l -> case PGF.readLanguage l of
- Nothing -> throwCGIError 400 "Bad language" ["Bad language: " ++ l]
- Just lang | lang `elem` PGF.languages pgf -> return $ Just lang
- | otherwise -> throwCGIError 400 "Unknown language" ["Unknown language: " ++ l]
+ Just l@(_:_) -> Just # readLang l
+ _ -> return Nothing
+
+ readLang :: String -> CGI PGF.Language
+ readLang l =
+ case PGF.readLanguage l of
+ Nothing -> throwCGIError 400 "Bad language" ["Bad language: " ++ l]
+ Just lang | lang `elem` PGF.languages pgf -> return lang
+ | otherwise -> throwCGIError 400 "Unknown language" ["Unknown language: " ++ l]
getIncludePrintNames :: CGI Bool
- getIncludePrintNames = maybe (return False) (\_->return True) =<< getInput "printnames"
+ getIncludePrintNames = maybe False (const True) # getInput "printnames"
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
doExternal Nothing input = throwCGIError 400 "Unknown external command" ["Unknown external command"]
@@ -172,8 +172,8 @@ doExternal (Just cmd) input =
liftIO $ removeFile tmpfile2
return r
-doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> Maybe Int -> JSValue
-doTranslate pgf input mcat mfrom mto mlimit =
+doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> JSValue
+doTranslate pgf input mcat mfrom tos mlimit =
showJSON
[makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po)
| (from,po,bs) <- parse' pgf input mcat mfrom]
@@ -185,7 +185,7 @@ doTranslate pgf input mcat mfrom mto mlimit =
[makeObj ["tree".=tree,
"linearizations".=
[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]]
PGF.ParseIncomplete -> ["incomplete".=True]
PGF.ParseFailed n -> ["parseFailed".=n]
@@ -196,8 +196,8 @@ jsonTypeErrors errs =
| (fid,err) <- errs]]
-- used in phrasebook
-doTranslateGroup :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> Maybe Int -> JSValue
-doTranslateGroup pgf input mcat mfrom mto mlimit =
+doTranslateGroup :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> JSValue
+doTranslateGroup pgf input mcat mfrom tos mlimit =
showJSON
[makeObj ["from".=langOnly (PGF.showLanguage from),
"to".=langOnly (PGF.showLanguage to),
@@ -207,7 +207,7 @@ doTranslateGroup pgf input mcat mfrom mto mlimit =
]
|
(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
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
cat = fromMaybe (PGF.startCat pgf) mcat
-doLinearize :: PGF -> PGF.Tree -> Maybe PGF.Language -> JSValue
-doLinearize pgf tree mto = showJSON
+doLinearize :: PGF -> PGF.Tree -> [PGF.Language] -> JSValue
+doLinearize pgf tree tos = showJSON
[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 tree mto = showJSON
+doLinearizes :: PGF -> PGF.Tree -> [PGF.Language] -> JSValue
+doLinearizes pgf tree tos = showJSON
[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 mcat mdepth mlimit mto =
+doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> [PGF.Language] -> IO JSValue
+doRandom pgf mcat mdepth mlimit tos =
do g <- newStdGen
let trees = PGF.generateRandomDepth g pgf cat (Just depth)
return $ showJSON
[makeObj ["tree".=PGF.showExpr [] tree,
- "linearizations".= doLinearizes pgf tree mto]
+ "linearizations".= doLinearizes pgf tree tos]
| tree <- limit trees]
where cat = fromMaybe (PGF.startCat pgf) mcat
limit = take (fromMaybe 1 mlimit)
depth = fromMaybe 4 mdepth
-doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> Maybe PGF.Language -> JSValue
-doGenerate pgf mcat mdepth mlimit mto =
+doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> [PGF.Language] -> JSValue
+doGenerate pgf mcat mdepth mlimit tos =
showJSON [makeObj ["tree".=PGF.showExpr [] tree,
"linearizations".=
[makeObj ["to".=to, "text".=text]
- | (to,text,bs) <- linearize' pgf mto tree]]
+ | (to,text,bs) <- linearize' pgf tos tree]]
| tree <- limit trees]
where
trees = PGF.generateAllDepth pgf cat (Just depth)
@@ -325,13 +325,13 @@ doGrammar pgf macc = showJSON $ makeObj
functions = [PGF.showCId fun | fun <- PGF.functions pgf]
outputGraphviz code =
- do format <- getFormat "png"
- case format of
+ do fmt <- format "png"
+ case fmt of
"gv" -> outputPlain code
- _ -> outputFPS' format =<< liftIO (pipeIt2graphviz format code)
+ _ -> outputFPS' fmt =<< liftIO (pipeIt2graphviz fmt code)
where
- outputFPS' format bs =
- do setHeader "Content-Type" (mimeType format)
+ outputFPS' fmt bs =
+ do setHeader "Content-Type" (mimeType fmt)
outputFPS bs
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
pipeIt2graphviz :: String -> String -> IO BS.ByteString
-pipeIt2graphviz format code = do
+pipeIt2graphviz fmt code = do
(Just inh, Just outh, _, pid) <-
- createProcess (proc "dot" ["-T",format])
+ createProcess (proc "dot" ["-T",fmt])
{ std_in = CreatePipe,
std_out = CreatePipe,
std_err = Inherit }
@@ -541,24 +541,24 @@ complete' pgf from typ mlimit input =
Left es -> (ps,w:ws)
Right ps -> loop ps ws
-linearize' :: PGF -> Maybe PGF.Language -> PGF.Tree -> [(PGF.Language,String,PGF.BracketedString)]
-linearize' pgf mto tree =
+linearize' :: PGF -> [PGF.Language] -> PGF.Tree -> [(PGF.Language,String,PGF.BracketedString)]
+linearize' pgf to tree =
[(to,s,bs) | to<-langs,
let bs = PGF.bracketedLinearize pgf to (transfer to tree)
s = unwords $ PGF.flattenBracketedString bs]
where
- langs = maybe (PGF.languages pgf) (:[]) mto
+ langs = if null to then PGF.languages pgf else to
transfer lang = if "LaTeX" `isSuffixOf` show lang
then fold -- OpenMath LaTeX transfer
else id
-- all variants and their forms
-linearizes' :: PGF -> Maybe PGF.Language -> PGF.Tree -> [(PGF.Language,[String])]
-linearizes' pgf mto tree =
+linearizes' :: PGF -> [PGF.Language] -> PGF.Tree -> [(PGF.Language,[String])]
+linearizes' pgf tos tree =
[(to,lins to (transfer to tree)) | to <- langs]
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
linearizeAndBind pgf mto t =
@@ -585,6 +585,8 @@ langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languag
-- * General utilities
f .= v = (f,showJSON v)
+f # x = fmap f x
+f % x = ap f x
--cleanFilePath :: FilePath -> FilePath
--cleanFilePath = takeFileName
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-30 06:24:04 +0000