forked from GitHub/gf-core
43e61a1e3b
Most PGF web API commands that produce linearizations now accept an unlexer parameter. Possible values are "text", "code" and "mixed". The web service now include Date and Last-Modified headers in the HTTP, responses. This means that browsers can treat responses as static content and cache them, so it becomes less critical to cache parse results in the server. Also did some cleanup in PGFService.hs, e.g. removed a couple of functions that can now be imported from PGF.Lexing instead.
845 lines
31 KiB
Haskell
845 lines
31 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
module PGFService(cgiMain,cgiMain',getPath,
|
|
logFile,stderrToFile,
|
|
newPGFCache,flushPGFCache) where
|
|
|
|
import PGF (PGF)
|
|
import qualified PGF
|
|
import PGF.Lexing
|
|
import Cache
|
|
import FastCGIUtils
|
|
import URLEncoding
|
|
|
|
#if C_RUNTIME
|
|
import qualified PGF2 as C
|
|
import Data.Time.Clock(UTCTime,getCurrentTime,diffUTCTime)
|
|
#endif
|
|
|
|
import Data.Time.Format(formatTime)
|
|
import System.Locale(defaultTimeLocale,rfc822DateFormat)
|
|
import Network.CGI
|
|
import Text.JSON
|
|
import Text.PrettyPrint as PP(render, text, (<+>))
|
|
import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
|
|
import qualified Data.ByteString.Lazy as BS
|
|
|
|
import Control.Concurrent
|
|
import qualified Control.Exception as E
|
|
import Control.Monad
|
|
import Control.Monad.State(State,evalState,get,put)
|
|
import Data.Char
|
|
import Data.Function (on)
|
|
import Data.List (sortBy,intersperse,mapAccumL,nub,isSuffixOf)
|
|
import qualified Data.Map as Map
|
|
import Data.Maybe
|
|
import System.Random
|
|
import System.Process
|
|
import System.Exit
|
|
import System.IO
|
|
import System.Directory(removeFile)
|
|
import System.Mem(performGC)
|
|
import Fold(fold) -- transfer function for OpenMath LaTeX
|
|
|
|
catchIOE :: IO a -> (E.IOException -> IO a) -> IO a
|
|
catchIOE = E.catch
|
|
|
|
logFile :: FilePath
|
|
logFile = "pgf-error.log"
|
|
|
|
#ifdef C_RUNTIME
|
|
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 = do pgfCache <- newCache PGF.readPGF
|
|
cCache <- newCache $ \ path -> do pgf <- C.readPGF path
|
|
pc <- newMVar Map.empty
|
|
return (pgf,pc)
|
|
return (pgfCache,cCache)
|
|
flushPGFCache (c1,c2) = flushCache c1 >> flushCache c2
|
|
#else
|
|
type Caches = (Cache PGF,())
|
|
newPGFCache = do pgfCache <- newCache PGF.readPGF
|
|
return (pgfCache,())
|
|
flushPGFCache (c1,_) = flushCache c1
|
|
#endif
|
|
|
|
getPath =
|
|
do path <- getVarWithDefault "PATH_TRANSLATED" "" -- apache mod_fastcgi
|
|
if null path
|
|
then getVarWithDefault "SCRIPT_FILENAME" "" -- lighttpd
|
|
else return path
|
|
|
|
cgiMain :: Caches -> CGI CGIResult
|
|
cgiMain cache = handleErrors . handleCGIErrors $
|
|
cgiMain' cache =<< getPath
|
|
|
|
cgiMain' :: Caches -> FilePath -> CGI CGIResult
|
|
cgiMain' cache path =
|
|
do command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString))
|
|
(getInput "command")
|
|
case command of
|
|
"download" -> outputBinary =<< liftIO (BS.readFile path)
|
|
'c':'-':_ ->
|
|
#ifdef C_RUNTIME
|
|
cpgfMain command =<< liftIO (readCache' (snd cache) path)
|
|
#else
|
|
serverError "Server configured without C run-time support" ""
|
|
#endif
|
|
_ -> pgfMain command =<< liftIO (readCache' (fst cache) path)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- * C run-time functionality
|
|
|
|
#ifdef C_RUNTIME
|
|
--cpgfMain :: String -> (C.PGF,MVar ParseCache) -> CGI CGIResult
|
|
cpgfMain command (t,(pgf,pc)) =
|
|
case command of
|
|
"c-parse" -> out t=<< join (parse # input % start % limit % trie)
|
|
"c-linearize" -> out t=<< lin # tree % to
|
|
"c-translate" -> out t=<< join (trans # input % to % start % limit % trie)
|
|
"c-flush" -> out t=<< flush
|
|
"c-grammar" -> out t grammar
|
|
_ -> badRequest "Unknown command" command
|
|
where
|
|
flush = liftIO $ do modifyMVar_ pc $ const $ return Map.empty
|
|
performGC
|
|
return $ showJSON ()
|
|
|
|
grammar = showJSON $ makeObj
|
|
["name".=C.abstractName pgf,
|
|
"startcat".=C.startCat pgf,
|
|
"languages".=languages]
|
|
where
|
|
languages = [makeObj ["name".= l] | (l,_)<-Map.toList (C.languages pgf)]
|
|
|
|
parse input@((from,_),_) start mlimit trie =
|
|
do r <- parse' start mlimit input
|
|
return $ showJSON [makeObj ("from".=from:jsonParseResult r)]
|
|
|
|
jsonParseResult = either bad good
|
|
where
|
|
bad err = ["parseFailed".=err]
|
|
good trees = "trees".=map tp trees :[] -- :addTrie trie trees
|
|
tp (tree,prob) = makeObj ["tree".=tree,"prob".=prob]
|
|
|
|
parse' start mlimit ((from,concr),input) =
|
|
liftIO $ do t <- getCurrentTime
|
|
fmap (maybe id take mlimit . drop start)
|
|
# modifyMVar pc (parse'' t)
|
|
where
|
|
key = (from,input)
|
|
parse'' t pc = maybe new old $ Map.lookup key pc
|
|
where
|
|
new = return (update (res,t) pc,res)
|
|
where res = C.parse concr (C.startCat pgf) input
|
|
old (res,_) = return (update (res,t) pc,res)
|
|
update r = Map.mapMaybe purge . Map.insert key r
|
|
purge r@(_,t') = if diffUTCTime t t'<120 then Just r else Nothing
|
|
-- remove unused parse results after 2 minutes
|
|
|
|
lin tree to = showJSON (lin' tree to)
|
|
lin' tree (tos,unlex) =
|
|
[makeObj ["to".=to,"text".=unlex (C.linearize c tree)]|(to,c)<-tos]
|
|
|
|
trans input@((from,_),_) to start mlimit trie =
|
|
do parses <- parse' start mlimit input
|
|
return $
|
|
showJSON [ makeObj ["from".=from,
|
|
"translations".= jsonParses parses]]
|
|
where
|
|
jsonParses = either bad good
|
|
where
|
|
bad err = [makeObj ["error".=err]]
|
|
good parses = [makeObj ["tree".=tree,
|
|
"prob".=prob,
|
|
"linearizations".=lin' tree to]
|
|
| (tree,prob) <- parses]
|
|
|
|
input = lexit # from % textInput
|
|
where
|
|
lexit (from,lex) input = (from,lex input)
|
|
|
|
from = maybe (missing "from") getlexer =<< getLang "from"
|
|
where
|
|
getlexer f@(_,concr) = (,) f # c_lexer concr
|
|
|
|
to = (,) # getLangs "to" % unlexer
|
|
|
|
getLangs = getLangs' readLang
|
|
getLang = getLang' readLang
|
|
|
|
readLang :: String -> CGI (String,C.Concr)
|
|
readLang lang =
|
|
case Map.lookup lang (C.languages pgf) of
|
|
Nothing -> badRequest "Bad language" lang
|
|
Just c -> return (lang,c)
|
|
|
|
tree = do s <- maybe (missing "tree") return =<< getInput1 "tree"
|
|
let t = C.readExpr s
|
|
maybe (badRequest "bad tree" s) return t
|
|
|
|
--c_lexer concr = lexer
|
|
c_lexer concr = ilexer (not . null . C.lookupMorpho concr)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
{-
|
|
instance JSON C.CId where
|
|
readJSON x = readJSON x >>= maybe (fail "Bad language.") return . C.readCId
|
|
showJSON = showJSON . C.showCId
|
|
-}
|
|
instance JSON C.Expr where
|
|
readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . C.readExpr
|
|
showJSON = showJSON . C.showExpr
|
|
|
|
#endif
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- * Lexing
|
|
|
|
-- | Lexers with a text lexer that tries to be a more clever with the first word
|
|
ilexer good = lexer' uncap
|
|
where
|
|
uncap s = if good s
|
|
then s
|
|
else uncapitInit s
|
|
|
|
-- | Standard lexers
|
|
lexer = lexer' uncapitInit
|
|
|
|
lexer' uncap = maybe (return id) lexerfun =<< getInput "lexer"
|
|
where
|
|
lexerfun name =
|
|
case name of
|
|
"text" -> return (unwords . lexText' uncap)
|
|
"code" -> return (unwords . lexCode)
|
|
"mixed" -> return (unwords . lexMixed)
|
|
_ -> badRequest "Unknown lexer" name
|
|
|
|
|
|
type Unlexer = String->String
|
|
|
|
unlexer :: CGI Unlexer
|
|
unlexer = maybe (return id) unlexerfun =<< getInput "unlexer"
|
|
where
|
|
unlexerfun name =
|
|
case name of
|
|
"text" -> return (unlexText' . words)
|
|
"code" -> return (unlexCode . words)
|
|
"mixed" -> return (unlexMixed . words)
|
|
_ -> badRequest "Unknown lexer" name
|
|
|
|
unlexText' ("+":ws) = "+ "++unlexText ws
|
|
unlexText' ("*":ws) = "* "++unlexText ws
|
|
unlexText' ws = unlexText ws
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- * Haskell run-time functionality
|
|
|
|
--pgfMain :: String -> PGF -> CGI CGIResult
|
|
pgfMain command (t,pgf) =
|
|
case command of
|
|
"parse" -> o =<< doParse pgf # input % cat % limit % trie
|
|
"complete" -> o =<< doComplete pgf # input % cat % limit
|
|
"linearize" -> o =<< doLinearize pgf # tree % to
|
|
"linearizeAll" -> o =<< doLinearizes pgf # tree % to
|
|
"linearizeTable" -> o =<< doLinearizeTabular pgf # tree % to
|
|
"random" -> cat >>= \c -> depth >>= \dp -> limit >>= \l -> to >>= \to -> liftIO (doRandom pgf c dp l to) >>= o
|
|
"generate" -> o =<< doGenerate pgf # cat % depth % limit % to
|
|
"translate" -> o =<< doTranslate pgf # input % cat % to % limit %trie
|
|
"translategroup" -> o =<< doTranslateGroup pgf # input % cat % to % limit
|
|
"grammar" -> o =<< doGrammar pgf # requestAcceptLanguage
|
|
"abstrtree" -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree
|
|
"alignment" -> outputGraphviz =<< alignment pgf # tree % to
|
|
"parsetree" -> do t <- tree
|
|
Just l <- from
|
|
opts <- graphvizOptions
|
|
outputGraphviz (parseTree pgf l opts t)
|
|
"abstrjson" -> o . jsonExpr =<< tree
|
|
"browse" -> join $ doBrowse pgf # optId % cssClass % href % format "html" % getIncludePrintNames
|
|
"external" -> do cmd <- getInput "external"
|
|
doExternal cmd =<< textInput
|
|
_ -> badRequest "Unknown command" command
|
|
where
|
|
o x = out t x
|
|
|
|
input = do fr <- from
|
|
lex <- mlexer fr
|
|
inp <- textInput
|
|
return (fr,lex inp)
|
|
|
|
mlexer Nothing = lexer
|
|
mlexer (Just lang) = ilexer (PGF.isInMorpho morpho)
|
|
where morpho = PGF.buildMorpho pgf lang
|
|
|
|
tree :: CGI PGF.Tree
|
|
tree = do ms <- getInput "tree"
|
|
s <- maybe (badRequest "No tree given" "") return ms
|
|
t <- maybe (badRequest "Bad tree" s) return (PGF.readExpr s)
|
|
t <- either (\err -> badRequest "Type incorrect tree"
|
|
(unlines $
|
|
[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 <- getInput1 "cat"
|
|
case mcat of
|
|
Nothing -> return Nothing
|
|
Just cat -> case PGF.readType cat of
|
|
Nothing -> badRequest "Bad category" cat
|
|
Just typ -> return $ Just typ -- typecheck the category
|
|
|
|
optId :: CGI (Maybe PGF.CId)
|
|
optId = maybe (return Nothing) rd =<< getInput "id"
|
|
where
|
|
rd = maybe err (return . Just) . PGF.readCId
|
|
err = badRequest "Bad identifier" []
|
|
|
|
cssClass, href :: CGI (Maybe String)
|
|
cssClass = getInput "css-class"
|
|
href = getInput "href"
|
|
|
|
getIncludePrintNames :: CGI Bool
|
|
getIncludePrintNames = maybe False (const True) # getInput "printnames"
|
|
|
|
graphvizOptions =
|
|
PGF.GraphvizOptions # bool "noleaves"
|
|
% bool "nofun"
|
|
% bool "nocat"
|
|
% string "nodefont"
|
|
% string "leaffont"
|
|
% string "nodecolor"
|
|
% string "leafcolor"
|
|
% string "nodeedgestyle"
|
|
% string "leafedgestyle"
|
|
where
|
|
string name = maybe "" id # getInput name
|
|
bool name = maybe False toBool # getInput name
|
|
|
|
from = getLang "from"
|
|
to = (,) # getLangs "to" % unlexer
|
|
|
|
getLangs = getLangs' readLang
|
|
getLang = getLang' readLang
|
|
|
|
readLang :: String -> CGI PGF.Language
|
|
readLang l =
|
|
case PGF.readLanguage l of
|
|
Nothing -> badRequest "Bad language" l
|
|
Just lang | lang `elem` PGF.languages pgf -> return lang
|
|
| otherwise -> badRequest "Unknown language" l
|
|
|
|
-- * Request parameter access and related auxiliary functions
|
|
|
|
--out = outputJSONP
|
|
out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t
|
|
setHeader "Last-Modified" fmt
|
|
outputJSONP r
|
|
|
|
getInput1 x = nonEmpty # getInput x
|
|
nonEmpty (Just "") = Nothing
|
|
nonEmpty r = r
|
|
|
|
textInput :: CGI String
|
|
textInput = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
|
|
|
|
getLangs' readLang i = mapM readLang . maybe [] words =<< getInput i
|
|
|
|
getLang' readLang i =
|
|
do mlang <- getInput i
|
|
case mlang of
|
|
Just l@(_:_) -> Just # readLang l
|
|
_ -> return Nothing
|
|
|
|
|
|
limit, depth :: CGI (Maybe Int)
|
|
limit = readInput "limit"
|
|
depth = readInput "depth"
|
|
|
|
start :: CGI Int
|
|
start = maybe 0 id # readInput "start"
|
|
|
|
trie :: CGI Bool
|
|
trie = maybe False toBool # getInput "trie"
|
|
|
|
toBool s = s `elem` ["","yes","true","True"]
|
|
|
|
missing = badRequest "Missing parameter"
|
|
errorMissingId = badRequest "Missing identifier" ""
|
|
|
|
badRequest = throw 400
|
|
serverError = throw 500
|
|
|
|
throw code msg extra =
|
|
throwCGIError code msg [msg ++(if null extra then "" else ": "++extra)]
|
|
|
|
format def = maybe def id # getInput "format"
|
|
|
|
-- * Request implementations
|
|
|
|
-- Hook for simple extensions of the PGF service
|
|
doExternal Nothing input = badRequest "Unknown external command" ""
|
|
doExternal (Just cmd) input =
|
|
do liftIO $ logError ("External command: "++cmd)
|
|
cmds <- liftIO $ (fmap lines $ readFile "external_services")
|
|
`catchIOE` const (return [])
|
|
liftIO $ logError ("External services: "++show cmds)
|
|
if cmd `elem` cmds then ok else err
|
|
where
|
|
err = badRequest "Unknown external command" cmd
|
|
ok =
|
|
do let tmpfile1 = "external_input.txt"
|
|
tmpfile2 = "external_output.txt"
|
|
liftIO $ writeFile "external_input.txt" input
|
|
liftIO $ system $ cmd ++ " " ++ tmpfile1 ++ " > " ++ tmpfile2
|
|
liftIO $ removeFile tmpfile1
|
|
r <- outputJSONP =<< liftIO (readFile tmpfile2)
|
|
liftIO $ removeFile tmpfile2
|
|
return r
|
|
|
|
type To = ([PGF.Language],Unlexer)
|
|
|
|
doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> Bool -> JSValue
|
|
doTranslate pgf (mfrom,input) mcat (tos,unlex) mlimit trie =
|
|
showJSON
|
|
[makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po)
|
|
| (from,po,bs) <- parse' pgf input mcat mfrom]
|
|
where
|
|
jsonTranslateOutput output =
|
|
case output of
|
|
PGF.ParseOk trees ->
|
|
addTrie trie trees++
|
|
["translations".=
|
|
[makeObj ["tree".=tree,
|
|
"linearizations".=
|
|
[makeObj ["to".=to, "text".=unlex text,
|
|
"brackets".=bs]
|
|
| (to,text,bs)<- linearizeAndBind pgf tos tree]]
|
|
| tree <- maybe id take mlimit trees]]
|
|
PGF.ParseIncomplete -> ["incomplete".=True]
|
|
PGF.ParseFailed n -> ["parseFailed".=n]
|
|
PGF.TypeError errs -> jsonTypeErrors errs
|
|
|
|
jsonTypeErrors errs =
|
|
["typeErrors".= [makeObj ["fid".=fid, "msg".=show (PGF.ppTcError err)]
|
|
| (fid,err) <- errs]]
|
|
|
|
-- used in phrasebook
|
|
doTranslateGroup :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> JSValue
|
|
doTranslateGroup pgf (mfrom,input) mcat (tos,unlex) mlimit =
|
|
showJSON
|
|
[makeObj ["from".=langOnly (PGF.showLanguage from),
|
|
"to".=langOnly (PGF.showLanguage to),
|
|
"linearizations".=
|
|
[toJSObject (("text",unlex alt) : disamb lg from ts)
|
|
| (ts,alt) <- output, let lg = length output]
|
|
]
|
|
|
|
|
(from,po,bs) <- parse' pgf input mcat mfrom,
|
|
(to,output) <- groupResults [(t, linearizeAndBind 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
|
|
where
|
|
collect tls = [(t,(l,s)) | (t,ls) <- tls, (l,s,_) <- ls, notDisamb l]
|
|
start ls = [(l,[([t],s)]) | (t,(l,s)) <- ls]
|
|
more (l,s) = Map.insertWith (\ [([t],x)] xs -> insertAlt t x xs) l s
|
|
|
|
insertAlt t x xs = case xs of
|
|
(ts,y):xs2 -> if x==y then (t:ts,y):xs2 -- if string is there add only tree
|
|
else (ts,y) : insertAlt t x xs2
|
|
_ -> [([t],x)]
|
|
|
|
langOnly = reverse . take 3 . reverse
|
|
|
|
disamb lg from ts =
|
|
if lg < 2
|
|
then []
|
|
else [("tree", "-- " ++ groupDisambs [unlex (disambLang from t) | t <- ts])]
|
|
|
|
groupDisambs = unwords . intersperse "/"
|
|
|
|
disambLang f t =
|
|
let
|
|
disfl lang = PGF.mkCId ("Disamb" ++ lang)
|
|
disf = disfl (PGF.showLanguage f)
|
|
disfEng = disfl (reverse (drop 3 (reverse (PGF.showLanguage f))) ++ "Eng")
|
|
in
|
|
if elem disf (PGF.languages pgf) -- if Disamb f exists use it
|
|
then PGF.linearize pgf disf t
|
|
else if elem disfEng (PGF.languages pgf) -- else try DisambEng
|
|
then PGF.linearize pgf disfEng t
|
|
else "AST " ++ PGF.showExpr [] t -- else show abstract tree
|
|
|
|
notDisamb = (/="Disamb") . take 6 . PGF.showLanguage
|
|
|
|
type From = (Maybe PGF.Language,String)
|
|
|
|
doParse :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue
|
|
doParse pgf (mfrom,input) mcat mlimit trie = showJSON $ map makeObj
|
|
["from".=from : "brackets".=bs : jsonParseOutput po
|
|
| (from,po,bs) <- parse' pgf input mcat mfrom]
|
|
where
|
|
jsonParseOutput output =
|
|
case output of
|
|
PGF.ParseOk trees -> ["trees".=maybe id take mlimit trees]
|
|
++addTrie trie trees
|
|
PGF.TypeError errs -> jsonTypeErrors errs
|
|
PGF.ParseIncomplete -> ["incomplete".=True]
|
|
PGF.ParseFailed n -> ["parseFailed".=n]
|
|
|
|
addTrie trie trees =
|
|
["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie]
|
|
|
|
doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> JSValue
|
|
doComplete pgf (mfrom,input) mcat mlimit = showJSON
|
|
[makeObj ["from".=from, "brackets".=bs, "completions".=cs, "text".=s]
|
|
| from <- froms, let (bs,s,cs) = complete' pgf from cat mlimit input]
|
|
where
|
|
froms = maybe (PGF.languages pgf) (:[]) mfrom
|
|
cat = fromMaybe (PGF.startCat pgf) mcat
|
|
|
|
doLinearize :: PGF -> PGF.Tree -> To -> JSValue
|
|
doLinearize pgf tree (tos,unlex) = showJSON
|
|
[makeObj ["to".=to, "text".=unlex text,"brackets".=bs]
|
|
| (to,text,bs) <- linearizeAndBind pgf tos tree]
|
|
|
|
doLinearizes :: PGF -> PGF.Tree -> To -> JSValue
|
|
doLinearizes pgf tree (tos,unlex) = showJSON
|
|
[makeObj ["to".=to, "texts".=map (unlex . doBind) texts]
|
|
| (to,texts) <- linearizes' pgf tos tree]
|
|
where
|
|
linearizes' pgf tos tree =
|
|
[(to,lins to (transfer to tree)) | to <- langs]
|
|
where
|
|
langs = if null tos then PGF.languages pgf else tos
|
|
lins to = nub . concatMap (map snd) . PGF.tabularLinearizes pgf to
|
|
|
|
doLinearizeTabular :: PGF -> PGF.Tree -> To -> JSValue
|
|
doLinearizeTabular pgf tree (tos,unlex) = showJSON
|
|
[makeObj ["to".=to,
|
|
"table".=[makeObj ["params".=ps,"texts".=map unlex ts]
|
|
| (ps,ts)<-texts]]
|
|
| (to,texts) <- linearizeTabular pgf tos tree]
|
|
|
|
doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> To -> IO JSValue
|
|
doRandom pgf mcat mdepth mlimit to =
|
|
do g <- newStdGen
|
|
let trees = PGF.generateRandomDepth g pgf cat (Just depth)
|
|
return $ showJSON
|
|
[makeObj ["tree".=PGF.showExpr [] tree,
|
|
"linearizations".= doLinearizes pgf tree to]
|
|
| 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 -> To -> JSValue
|
|
doGenerate pgf mcat mdepth mlimit (tos,unlex) =
|
|
showJSON [makeObj ["tree".=PGF.showExpr [] tree,
|
|
"linearizations".=
|
|
[makeObj ["to".=to, "text".=unlex text]
|
|
| (to,text,bs) <- linearizeAndBind pgf tos tree]]
|
|
| tree <- limit trees]
|
|
where
|
|
trees = PGF.generateAllDepth pgf cat (Just depth)
|
|
cat = fromMaybe (PGF.startCat pgf) mcat
|
|
limit = take (fromMaybe 1 mlimit)
|
|
depth = fromMaybe 4 mdepth
|
|
|
|
doGrammar :: PGF -> Maybe (Accept Language) -> JSValue
|
|
doGrammar pgf macc = showJSON $ makeObj
|
|
["name".=PGF.abstractName pgf,
|
|
"userLanguage".=selectLanguage pgf macc,
|
|
"startcat".=PGF.showType [] (PGF.startCat pgf),
|
|
"categories".=categories,
|
|
"functions".=functions,
|
|
"languages".=languages]
|
|
where
|
|
languages =
|
|
[makeObj ["name".= l,
|
|
"languageCode".= fromMaybe "" (PGF.languageCode pgf l)]
|
|
| l <- PGF.languages pgf]
|
|
categories = [PGF.showCId cat | cat <- PGF.categories pgf]
|
|
functions = [PGF.showCId fun | fun <- PGF.functions pgf]
|
|
|
|
outputGraphviz code =
|
|
do fmt <- format "png"
|
|
case fmt of
|
|
"gv" -> outputPlain code
|
|
_ -> outputFPS' fmt =<< liftIO (pipeIt2graphviz fmt code)
|
|
where
|
|
outputFPS' fmt bs =
|
|
do setHeader "Content-Type" (mimeType fmt)
|
|
outputFPS bs
|
|
|
|
mimeType fmt =
|
|
case fmt of
|
|
"png" -> "image/png"
|
|
"gif" -> "image/gif"
|
|
"svg" -> "image/svg+xml"
|
|
-- ...
|
|
_ -> "application/binary"
|
|
|
|
abstrTree pgf opts tree = PGF.graphvizAbstractTree pgf opts' tree
|
|
where opts' = (not (PGF.noFun opts),not (PGF.noCat opts))
|
|
|
|
parseTree pgf lang opts tree = PGF.graphvizParseTree pgf lang opts tree
|
|
|
|
alignment pgf tree (tos,unlex) = PGF.graphvizAlignment pgf tos' tree
|
|
where tos' = if null tos then PGF.languages pgf else tos
|
|
|
|
pipeIt2graphviz :: String -> String -> IO BS.ByteString
|
|
pipeIt2graphviz fmt code = do
|
|
(Just inh, Just outh, _, pid) <-
|
|
createProcess (proc "dot" ["-T",fmt])
|
|
{ std_in = CreatePipe,
|
|
std_out = CreatePipe,
|
|
std_err = Inherit }
|
|
|
|
hSetBinaryMode outh True
|
|
hSetEncoding inh utf8
|
|
|
|
-- fork off a thread to start consuming the output
|
|
output <- BS.hGetContents outh
|
|
outMVar <- newEmptyMVar
|
|
_ <- forkIO $ E.evaluate (BS.length output) >> putMVar outMVar ()
|
|
|
|
-- now write and flush any input
|
|
hPutStr inh code
|
|
hFlush inh
|
|
hClose inh -- done with stdin
|
|
|
|
-- wait on the output
|
|
takeMVar outMVar
|
|
hClose outh
|
|
|
|
-- wait on the process
|
|
ex <- waitForProcess pid
|
|
|
|
case ex of
|
|
ExitSuccess -> return output
|
|
ExitFailure r -> fail ("pipeIt2graphviz: (exit " ++ show r ++ ")")
|
|
|
|
browse1json pgf id pn = makeObj . maybe [] obj $ PGF.browse pgf id
|
|
where
|
|
obj (def,ps,cs) = if pn then (baseobj ++ pnames) else baseobj
|
|
where
|
|
baseobj = ["def".=def, "producers".=ps, "consumers".=cs]
|
|
pnames = ["printnames".=makeObj [(show lang).=PGF.showPrintName pgf lang id | lang <- PGF.languages pgf]]
|
|
|
|
|
|
doBrowse pgf (Just id) _ _ "json" pn = outputJSONP $ browse1json pgf id pn
|
|
doBrowse pgf Nothing _ _ "json" pn =
|
|
outputJSONP $ makeObj ["cats".=all (PGF.categories pgf),
|
|
"funs".=all (PGF.functions pgf)]
|
|
where
|
|
all = makeObj . map one
|
|
one id = PGF.showCId id.=browse1json pgf id pn
|
|
|
|
doBrowse pgf Nothing cssClass href _ pn = errorMissingId
|
|
doBrowse pgf (Just id) cssClass href _ pn = -- default to "html" format
|
|
outputHTML $
|
|
case PGF.browse pgf id of
|
|
Just (def,ps,cs) -> "<PRE>"++annotate def++"</PRE>\n"++
|
|
syntax++
|
|
(if not (null ps)
|
|
then "<BR/>"++
|
|
"<H3>Producers</H3>"++
|
|
"<P>"++annotateCIds ps++"</P>\n"
|
|
else "")++
|
|
(if not (null cs)
|
|
then "<BR/>"++
|
|
"<H3>Consumers</H3>"++
|
|
"<P>"++annotateCIds cs++"</P>\n"
|
|
else "")++
|
|
(if pn
|
|
then "<BR/>"++
|
|
"<H3>Print Names</H3>"++
|
|
"<P>"++annotatePrintNames++"</P>\n"
|
|
else "")
|
|
Nothing -> ""
|
|
where
|
|
syntax =
|
|
case PGF.functionType pgf id of
|
|
Just ty -> let (hypos,_,_) = PGF.unType ty
|
|
e = PGF.mkApp id (snd $ mapAccumL mkArg (1,1) hypos)
|
|
rows = ["<TR class=\"my-SyntaxRow\">"++
|
|
"<TD class=\"my-SyntaxLang\">"++PGF.showCId lang++"</TD>"++
|
|
"<TD class=\"my-SyntaxLin\">"++PGF.linearize pgf lang e++"</TD>"++
|
|
"</TR>"
|
|
| lang <- PGF.languages pgf]
|
|
in "<BR/>"++
|
|
"<H3>Syntax</H3>"++
|
|
"<TABLE class=\"my-SyntaxTable\">\n"++
|
|
"<TR class=\"my-SyntaxRow\">"++
|
|
"<TD class=\"my-SyntaxLang\">"++PGF.showCId (PGF.abstractName pgf)++"</TD>"++
|
|
"<TD class=\"my-SyntaxLin\">"++PGF.showExpr [] e++"</TD>"++
|
|
"</TR>\n"++
|
|
unlines rows++"\n</TABLE>"
|
|
Nothing -> ""
|
|
|
|
mkArg (i,j) (_,_,ty) = ((i+1,j+length hypos),e)
|
|
where
|
|
e = foldr (\(j,(bt,_,_)) -> PGF.mkAbs bt (PGF.mkCId ('X':show j))) (PGF.mkMeta i) (zip [j..] hypos)
|
|
(hypos,_,_) = PGF.unType ty
|
|
|
|
identifiers = PGF.functions pgf ++ PGF.categories pgf
|
|
|
|
annotate [] = []
|
|
annotate (c:cs)
|
|
| isIdentInitial c = let (id,cs') = break (not . isIdentChar) (c:cs)
|
|
in (if PGF.mkCId id `elem` identifiers
|
|
then mkLink id
|
|
else if id == "fun" || id == "data" || id == "cat" || id == "def"
|
|
then "<B>"++id++"</B>"
|
|
else id) ++
|
|
annotate cs'
|
|
| otherwise = c : annotate cs
|
|
|
|
annotateCIds ids = unwords (map (mkLink . PGF.showCId) ids)
|
|
|
|
isIdentInitial c = isAlpha c || c == '_'
|
|
isIdentChar c = isAlphaNum c || c == '_' || c == '\''
|
|
|
|
hrefAttr id =
|
|
case href of
|
|
Nothing -> ""
|
|
Just s -> "href=\""++substId id s++"\""
|
|
|
|
substId id [] = []
|
|
substId id ('$':'I':'D':cs) = id ++ cs
|
|
substId id (c:cs) = c : substId id cs
|
|
|
|
classAttr =
|
|
case cssClass of
|
|
Nothing -> ""
|
|
Just s -> "class=\""++s++"\""
|
|
|
|
mkLink s = "<A "++hrefAttr s++" "++classAttr++">"++s++"</A>"
|
|
|
|
annotatePrintNames = "<DL>"++(unwords pns)++"</DL>"
|
|
where pns = ["<DT>"++(show lang)++"</DT><DD>"++(PGF.showPrintName pgf lang id)++"</DD>" | lang <- PGF.languages pgf ]
|
|
|
|
-- | Render trees as JSON with numbered functions
|
|
jsonExpr e = evalState (expr (PGF.toATree e)) 0
|
|
where
|
|
expr e =
|
|
case e of
|
|
PGF.Other e -> return (makeObj ["other".=e])
|
|
PGF.App f es ->
|
|
do js <- mapM expr es
|
|
let children=["children".=js | not (null js)]
|
|
i<-inc
|
|
return $ makeObj (["fun".=f,"fid".=i]++children)
|
|
|
|
inc :: State Int Int
|
|
inc = do i <- get; put (i+1); return i
|
|
|
|
instance JSON PGF.Trie where
|
|
showJSON (PGF.Oth e) = makeObj ["other".=e]
|
|
showJSON (PGF.Ap f [[]]) = makeObj ["fun".=f] -- leaf
|
|
-- showJSON (PGF.Ap f [es]) = makeObj ["fun".=f,"children".=es] -- one alternative
|
|
showJSON (PGF.Ap f alts) = makeObj ["fun".=f,"alts".=alts]
|
|
|
|
instance JSON PGF.CId where
|
|
readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage
|
|
showJSON = showJSON . PGF.showLanguage
|
|
|
|
instance JSON PGF.Expr where
|
|
readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . PGF.readExpr
|
|
showJSON = showJSON . PGF.showExpr []
|
|
|
|
instance JSON PGF.BracketedString where
|
|
readJSON x = return (PGF.Leaf "")
|
|
showJSON (PGF.Bracket cat fid index fun _ bs) =
|
|
makeObj ["cat".=cat, "fid".=fid, "index".=index, "fun".=fun, "children".=bs]
|
|
showJSON (PGF.Leaf s) = makeObj ["token".=s]
|
|
|
|
-- * PGF utilities
|
|
|
|
cat :: PGF -> Maybe PGF.Type -> PGF.Type
|
|
cat pgf mcat = fromMaybe (PGF.startCat pgf) mcat
|
|
|
|
parse' :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [(PGF.Language,PGF.ParseOutput,PGF.BracketedString)]
|
|
parse' pgf input mcat mfrom =
|
|
[(from,po,bs) | from <- froms, (po,bs) <- [PGF.parse_ pgf from cat Nothing input]]
|
|
where froms = maybe (PGF.languages pgf) (:[]) mfrom
|
|
cat = fromMaybe (PGF.startCat pgf) mcat
|
|
|
|
complete' :: PGF -> PGF.Language -> PGF.Type -> Maybe Int -> String
|
|
-> (PGF.BracketedString, String, [String])
|
|
complete' pgf from typ mlimit input =
|
|
let (ws,prefix) = tokensAndPrefix input
|
|
ps0 = PGF.initState pgf from typ
|
|
(ps,ws') = loop ps0 ws
|
|
bs = snd (PGF.getParseOutput ps typ Nothing)
|
|
in if not (null ws')
|
|
then (bs, unwords (if null prefix then ws' else ws'++[prefix]), [])
|
|
else (bs, prefix, maybe id take mlimit $ order $ Map.keys (PGF.getCompletions ps prefix))
|
|
where
|
|
order = sortBy (compare `on` map toLower)
|
|
|
|
tokensAndPrefix :: String -> ([String],String)
|
|
tokensAndPrefix s | not (null s) && isSpace (last s) = (ws, "")
|
|
| null ws = ([],"")
|
|
| otherwise = (init ws, last ws)
|
|
where ws = words s
|
|
|
|
loop ps [] = (ps,[])
|
|
loop ps (w:ws) = case PGF.nextState ps (PGF.simpleParseInput w) of
|
|
Left es -> (ps,w:ws)
|
|
Right ps -> loop ps ws
|
|
|
|
transfer lang = if "LaTeX" `isSuffixOf` show lang
|
|
then fold -- OpenMath LaTeX transfer
|
|
else id
|
|
|
|
-- | tabulate all variants and their forms
|
|
linearizeTabular
|
|
:: PGF -> [PGF.Language] -> PGF.Tree -> [(PGF.Language,[(String,[String])])]
|
|
linearizeTabular pgf tos tree =
|
|
[(to,lintab to (transfer to tree)) | to <- langs]
|
|
where
|
|
langs = if null tos then PGF.languages pgf else tos
|
|
lintab to t = [(p,map doBind (nub [t|(p',t)<-vs,p'==p]))|p<-ps]
|
|
where
|
|
ps = nub (map fst vs)
|
|
vs = concat (PGF.tabularLinearizes pgf to t)
|
|
|
|
linearizeAndBind pgf mto tree =
|
|
[(to,s,bss) | to<-langs,
|
|
let bss = PGF.bracketedLinearize pgf to (transfer to tree)
|
|
s = unwords . bindTok $ concatMap PGF.flattenBracketedString bss]
|
|
where
|
|
langs = if null mto then PGF.languages pgf else mto
|
|
|
|
doBind = unwords . bindTok . words
|
|
|
|
selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language
|
|
selectLanguage pgf macc = case acceptable of
|
|
[] -> case PGF.languages pgf of
|
|
[] -> error "No concrete syntaxes in PGF grammar."
|
|
l:_ -> l
|
|
Language c:_ -> fromJust (langCodeLanguage pgf c)
|
|
where langCodes = mapMaybe (PGF.languageCode pgf) (PGF.languages pgf)
|
|
acceptable = negotiate (map Language langCodes) macc
|
|
|
|
langCodeLanguage :: PGF -> String -> Maybe PGF.Language
|
|
langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languageCode pgf l == Just code]
|
|
|
|
-- * General utilities
|
|
|
|
f .= v = (f,showJSON v)
|
|
f # x = fmap f x
|
|
f % x = ap f x
|
|
|
|
--cleanFilePath :: FilePath -> FilePath
|
|
--cleanFilePath = takeFileName
|