gf-3.6: src/server/PGFService.hs
{-# LANGUAGE CPP #-}
module PGFService(cgiMain,cgiMain',getPath,
logFile,stderrToFile,
newPGFCache,flushPGFCache,listPGFCache) 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(getCurrentTime,diffUTCTime)
#endif
import Data.Time.Clock(UTCTime)
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.IO.Error(isDoesNotExistError)
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
listPGFCache (c1,c2) = (,) # listCache c1 % listCache c2
#else
type Caches = (Cache PGF,())
newPGFCache = do pgfCache <- newCache PGF.readPGF
return (pgfCache,())
flushPGFCache (c1,_) = flushCache c1
listPGFCache (c1,_) = (,) # listCache c1 % return []
#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 =<< getFile BS.readFile path
'c':'-':_ ->
#ifdef C_RUNTIME
cpgfMain command =<< getFile (readCache' (snd cache)) path
#else
serverError "Server configured without C run-time support" ""
#endif
_ -> pgfMain command =<< getFile (readCache' (fst cache)) path
getFile get path =
either failed return =<< liftIO (E.try (get path))
where
failed e = if isDoesNotExistError e
then notFound path
else liftIO $ ioError e
--------------------------------------------------------------------------------
-- * 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-lookupmorpho"-> out t=<< morpho # from1 % textInput
"c-flush" -> out t=<< flush
"c-grammar" -> out t grammar
"c-wordforword" -> out t =<< wordforword # input % to
_ -> badRequest "Unknown command" command
where
flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
performGC
return $ showJSON ()
cat = C.startCat pgf
langs = C.languages pgf
grammar = showJSON $ makeObj
["name".=C.abstractName pgf,
"lastmodified".=show t,
"startcat".=C.startCat pgf,
"languages".=languages]
where
languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]
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]
-- Without caching parse results:
parse' start mlimit ((_,concr),input) =
return $
maybe id take mlimit . drop start # C.parse concr cat input
{-
-- Caching parse results:
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 cat 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]
morpho (from,concr) input =
showJSON [makeObj ["lemma".=l,"analysis".=a,"prob".=p]|(l,a,p)<-ms]
where ms = C.lookupMorpho concr input
wordforword input@((from,_),_) = jsonWFW from . wordforword' input
jsonWFW from rs =
showJSON
[makeObj
["from".=from,
"translations".=[makeObj ["linearizations".=
[makeObj["to".=to,"text".=text]
| (to,text)<-rs]]]]]
wordforword' inp@((from,concr),input) (tos,unlex) =
[(to,unlex . unwords $ map (lin_word' c) pws)
|let pws=map parse_word' (words input),(to,c)<-tos]
where
lin_word' c = either id (lin1 c)
lin1 c = dropq . C.linearize c
where
dropq (q:' ':s) | q `elem` "+*" = s
dropq s = s
parse_word' w = if all (\c->isSpace c||isPunctuation c) w
then Left w
else parse_word w
parse_word w =
maybe (Left ("["++w++"]")) Right $
msum [parse1 w,parse1 ow,morph w,morph ow]
where
ow = if w==lw then capitInit w else lw
lw = uncapitInit w
parse1 = either (const Nothing) (fmap fst . listToMaybe) .
C.parse concr cat
morph w = listToMaybe
[t | (f,a,p)<-C.lookupMorpho concr w,
t<-maybeToList (C.readExpr f)]
---
input = lexit # from % textInput
where
lexit (from,lex) input = (from,lex input)
from = maybe (missing "from") getlexer =<< from'
where
getlexer f@(_,concr) = (,) f # c_lexer concr
from1 = maybe (missing "from") return =<< from'
from' = getLang "from"
to = (,) # getLangs "to" % unlexer
getLangs = getLangs' readLang
getLang = getLang' readLang
readLang :: String -> CGI (String,C.Concr)
readLang lang =
case Map.lookup lang langs 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" -> o =<< join (doRandom pgf # cat % depth % limit % to)
"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
"lookupmorpho" -> o =<< doLookupMorpho pgf # from1 % textInput
"grammar" -> o =<< doGrammar t pgf # requestAcceptLanguage
"abstrtree" -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree
"alignment" -> outputGraphviz =<< alignment pgf # tree % to
"parsetree" -> outputGraphviz =<< parseTree pgf # from1 % graphvizOptions % tree
"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
from1 = maybe (missing "from") return =<< from
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" ""
notFound = throw 404 "Not found"
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
doLookupMorpho :: PGF -> PGF.Language -> String -> JSValue
doLookupMorpho pgf from input =
showJSON [makeObj ["lemma".=l,"analysis".=a]|(l,a)<-ms]
where
ms = PGF.lookupMorpho (PGF.buildMorpho pgf from) input
type From = (Maybe PGF.Language,String)
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
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 -> CGI JSValue
doRandom pgf mcat mdepth mlimit to =
liftIO $
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 :: UTCTime -> PGF -> Maybe (Accept Language) -> JSValue
doGrammar t pgf macc = showJSON $ makeObj
["name".=PGF.abstractName pgf,
"lastmodified".=show t,
"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
infixl 2 #,%
f .= v = (f,showJSON v)
f # x = fmap f x
f % x = ap f x
--cleanFilePath :: FilePath -> FilePath
--cleanFilePath = takeFileName