forked from GitHub/gf-core
restore the web server
This commit is contained in:
krangelov
35
gf.cabal
35
gf.cabal
@@ -212,6 +212,41 @@ executable gf
|
||||
terminfo >=0.4.0 && < 0.5,
|
||||
unix >= 2.7.2 && < 2.8
|
||||
|
||||
if flag(server)
|
||||
build-depends:
|
||||
cgi >= 3001.3.0.2 && < 3001.6,
|
||||
httpd-shed >= 0.4.0 && < 0.5,
|
||||
network>=2.3 && <2.7
|
||||
if flag(network-uri)
|
||||
build-depends:
|
||||
network-uri >= 2.6.1.0 && < 2.7,
|
||||
network>=2.6 && <2.7
|
||||
else
|
||||
build-depends:
|
||||
network >= 2.5 && <2.6
|
||||
|
||||
cpp-options: -DSERVER_MODE
|
||||
other-modules:
|
||||
GF.Server
|
||||
PGFService
|
||||
RunHTTP
|
||||
SimpleEditor.Convert
|
||||
SimpleEditor.JSON
|
||||
SimpleEditor.Syntax
|
||||
URLEncoding
|
||||
CGI
|
||||
CGIUtils
|
||||
Cache
|
||||
hs-source-dirs:
|
||||
src/server
|
||||
src/server/transfer
|
||||
|
||||
if flag(interrupt)
|
||||
cpp-options: -DUSE_INTERRUPT
|
||||
other-modules: GF.System.UseSignal
|
||||
else
|
||||
other-modules: GF.System.NoSignal
|
||||
|
||||
test-suite gf-tests
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: run.hs
|
||||
|
||||
@@ -17,7 +17,7 @@ import GF.Grammar.Printer(ppParams,ppTerm,getAbs,TermPrintQual(..))
|
||||
import GF.Grammar.Parser(runP,pModDef)
|
||||
import GF.Grammar.Lexer(Posn(..))
|
||||
import GF.Data.ErrM
|
||||
import PGF2.Internal(Literal(LStr))
|
||||
import PGF2(Literal(LStr))
|
||||
|
||||
import SimpleEditor.Syntax as S
|
||||
import SimpleEditor.JSON
|
||||
@@ -119,7 +119,7 @@ convCncJment (name,jment) =
|
||||
case jment of
|
||||
ResParam ops _ ->
|
||||
return $ Pa $ Param i (maybe "" (render . ppParams q . unLoc) ops)
|
||||
ResValue _ -> return Ignored
|
||||
ResValue _ _ -> return Ignored
|
||||
CncCat (Just (L _ typ)) Nothing Nothing pprn _ -> -- ignores printname !!
|
||||
return $ LC $ Lincat i (render $ ppTerm q 0 typ)
|
||||
ResOper oltyp (Just lterm) -> return $ Op $ Oper lhs rhs
|
||||
|
||||
@@ -44,7 +44,6 @@ import System.IO.Error(isDoesNotExistError)
|
||||
import System.Directory(removeFile)
|
||||
import System.FilePath(dropExtension,takeDirectory,(</>),(<.>))
|
||||
import System.Mem(performGC)
|
||||
import Fold(fold) -- transfer function for OpenMath LaTeX
|
||||
|
||||
catchIOE :: IO a -> (E.IOException -> IO a) -> IO a
|
||||
catchIOE = E.catch
|
||||
@@ -103,62 +102,39 @@ getFile get path =
|
||||
|
||||
pgfMain qsem command (t,pgf) =
|
||||
case command of
|
||||
<<<<<<< HEAD
|
||||
"parse" -> withQSem qsem $
|
||||
out t=<< join (parse # input % start % limit % treeopts)
|
||||
"linearize" -> out t=<< lin # tree % to
|
||||
"bracketedLinearize"
|
||||
-> out t=<< bracketedLin # tree % to
|
||||
"linearizeAll"-> out t=<< linAll # tree % to
|
||||
"translate" -> withQSem qsem $
|
||||
out t=<<join(trans # input % to % start % limit%treeopts)
|
||||
"lookupmorpho"-> out t=<< morpho # from1 % textInput
|
||||
"flush" -> out t=<< flush
|
||||
"grammar" -> out t grammar
|
||||
"abstrtree" -> outputGraphviz=<< graphvizAbstractTree pgf graphvizDefaults # tree
|
||||
"parsetree" -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from1 %tree
|
||||
"wordforword" -> out t =<< wordforword # input % to
|
||||
_ -> badRequest "Unknown command" command
|
||||
=======
|
||||
"c-parse" -> withQSem qsem $
|
||||
"parse" -> withQSem qsem $
|
||||
out t=<< join (parse # input % cat % start % limit % treeopts)
|
||||
"c-parseToChart"-> withQSem qsem $
|
||||
out t=<< join (parseToChart # input % cat % limit)
|
||||
"c-linearize" -> out t=<< lin # tree % to
|
||||
"c-bracketedLinearize"
|
||||
-- "parseToChart" -> withQSem qsem $
|
||||
-- out t=<< join (parseToChart # input % cat % limit)
|
||||
"linearize" -> out t=<< lin # tree % to
|
||||
"bracketedLinearize"
|
||||
-> out t=<< bracketedLin # tree % to
|
||||
"c-linearizeAll"-> out t=<< linAll # tree % to
|
||||
"c-translate" -> withQSem qsem $
|
||||
"linearizeAll" -> out t=<< linAll # tree % to
|
||||
"translate" -> withQSem qsem $
|
||||
out t=<<join(trans # input % cat % to % start % limit%treeopts)
|
||||
"c-lookupmorpho"-> out t=<< morpho # from1 % textInput
|
||||
"c-lookupcohorts"->out t=<< cohorts # from1 % getInput "filter" % textInput
|
||||
"c-flush" -> out t=<< flush
|
||||
"c-grammar" -> out t grammar
|
||||
"c-abstrtree" -> outputGraphviz=<< C.graphvizAbstractTree pgf C.graphvizDefaults # tree
|
||||
"c-parsetree" -> outputGraphviz=<< (\cnc -> C.graphvizParseTree cnc C.graphvizDefaults) . snd # from1 %tree
|
||||
"c-wordforword" -> out t =<< wordforword # input % cat % to
|
||||
"lookupmorpho" -> out t=<< morpho # from1 % textInput
|
||||
"lookupcohorts" -> out t=<< cohorts # from1 % getInput "filter" % textInput
|
||||
"flush" -> out t=<< flush
|
||||
"grammar" -> out t grammar
|
||||
"abstrtree" -> outputGraphviz=<< graphvizAbstractTree pgf graphvizDefaults # tree
|
||||
"parsetree" -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from1 %tree
|
||||
"wordforword" -> out t =<< wordforword # input % cat % to
|
||||
_ -> badRequest "Unknown command" command
|
||||
>>>>>>> master
|
||||
where
|
||||
flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
|
||||
performGC
|
||||
return $ showJSON ()
|
||||
|
||||
<<<<<<< HEAD
|
||||
cat = startCat pgf
|
||||
langs = languages pgf
|
||||
=======
|
||||
cat :: CGI C.Type
|
||||
cat :: CGI Type
|
||||
cat =
|
||||
do mcat <- getInput1 "cat"
|
||||
case mcat of
|
||||
Nothing -> return (C.startCat pgf)
|
||||
Just cat -> case C.readType cat of
|
||||
Nothing -> return (startCat pgf)
|
||||
Just cat -> case readType cat of
|
||||
Nothing -> badRequest "Bad category" cat
|
||||
Just typ -> return typ
|
||||
|
||||
langs = C.languages pgf
|
||||
>>>>>>> master
|
||||
langs = languages pgf
|
||||
|
||||
grammar = showJSON $ makeObj
|
||||
["name".=abstractName pgf,
|
||||
@@ -180,48 +156,20 @@ pgfMain qsem command (t,pgf) =
|
||||
,"prob".=prob
|
||||
]
|
||||
|
||||
<<<<<<< HEAD
|
||||
parse' start mlimit ((from,concr),input) =
|
||||
-- Without caching parse results:
|
||||
parse' cat start mlimit ((from,concr),input) =
|
||||
case parseWithHeuristics concr cat input (-1) callbacks of
|
||||
ParseOk ts -> return (Right (maybe id take mlimit (drop start ts)))
|
||||
ParseFailed _ tok -> return (Left tok)
|
||||
ParseIncomplete -> return (Left "")
|
||||
=======
|
||||
-- Without caching parse results:
|
||||
parse' cat start mlimit ((from,concr),input) =
|
||||
case C.parseWithHeuristics concr cat input (-1) callbacks of
|
||||
C.ParseOk ts -> return (Right (maybe id take mlimit (drop start ts)))
|
||||
C.ParseFailed _ tok -> return (Left tok)
|
||||
C.ParseIncomplete -> return (Left "")
|
||||
>>>>>>> master
|
||||
where
|
||||
callbacks = maybe [] cb $ lookup (abstractName pgf) literalCallbacks
|
||||
cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs]
|
||||
<<<<<<< HEAD
|
||||
=======
|
||||
{-
|
||||
-- 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
|
||||
-}
|
||||
where
|
||||
callbacks = undefined
|
||||
|
||||
parseToChart ((from,concr),input) cat mlimit =
|
||||
parseToChart ((from,concr),input) cat mlimit = undefined {-
|
||||
do r <- case C.parseToChart concr cat input (-1) callbacks (fromMaybe 5 mlimit) of
|
||||
C.ParseOk chart -> return (good chart)
|
||||
C.ParseFailed _ tok -> return (bad tok)
|
||||
C.ParseIncomplete -> return (bad "")
|
||||
ParseOk chart -> return (good chart)
|
||||
ParseFailed _ tok -> return (bad tok)
|
||||
ParseIncomplete -> return (bad "")
|
||||
return $ showJSON [makeObj ("from".=from:r)]
|
||||
where
|
||||
callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks
|
||||
@@ -243,9 +191,8 @@ pgfMain qsem command (t,pgf) =
|
||||
mkChartProd (expr,args,prob) =
|
||||
makeObj ["tree".=expr,"args".=map mkChartPArg args,"prob".=prob]
|
||||
|
||||
mkChartPArg (C.PArg _ fid) = showJSON fid
|
||||
>>>>>>> master
|
||||
|
||||
mkChartPArg (PArg _ fid) = showJSON fid
|
||||
-}
|
||||
linAll tree to = showJSON (linAll' tree to)
|
||||
linAll' tree (tos,unlex) =
|
||||
[makeObj ["to".=to,
|
||||
@@ -274,17 +221,10 @@ pgfMain qsem command (t,pgf) =
|
||||
| (tree,prob) <- parses]
|
||||
|
||||
morpho (from,concr) input =
|
||||
<<<<<<< HEAD
|
||||
showJSON [makeObj ["lemma".=l,"analysis".=a,"prob".=p]|(l,a,p)<-ms]
|
||||
where ms = lookupMorpho concr input
|
||||
|
||||
|
||||
wordforword input@((from,_),_) = jsonWFW from . wordforword' input
|
||||
=======
|
||||
showJSON [makeObj ["lemma".=l
|
||||
,"analysis".=a
|
||||
,"prob".=p]
|
||||
| (l,a,p)<-C.lookupMorpho concr input]
|
||||
| (l,a,p)<-lookupMorpho concr input]
|
||||
|
||||
cohorts (from,concr) filter input =
|
||||
showJSON [makeObj ["start" .=showJSON s
|
||||
@@ -296,13 +236,12 @@ pgfMain qsem command (t,pgf) =
|
||||
,"end" .=showJSON e
|
||||
]
|
||||
| (s,w,ms,e) <- (case filter of
|
||||
Just "longest" -> C.filterLongest
|
||||
Just "best" -> C.filterBest
|
||||
Just "longest" -> filterLongest
|
||||
Just "best" -> filterBest
|
||||
_ -> id)
|
||||
(C.lookupCohorts concr input)]
|
||||
(lookupCohorts concr input)]
|
||||
|
||||
wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat
|
||||
>>>>>>> master
|
||||
|
||||
jsonWFW from rs =
|
||||
showJSON
|
||||
@@ -408,118 +347,6 @@ unlexer' defaultUnlexer good =
|
||||
cleanMarker ('*':cs) = cs
|
||||
cleanMarker cs = cs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- * Haskell run-time functionality
|
||||
{-
|
||||
--pgfMain :: Cache Labels -> FilePath -> String -> PGF -> CGI CGIResult
|
||||
pgfMain lcs@(alc,clc) path command tpgf@(t,pgf) =
|
||||
case command of
|
||||
"parse" -> o =<< doParse pgf # input % cat % limit % treeopts
|
||||
"complete" -> o =<< doComplete pgf # input % cat % limit % full
|
||||
"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%treeopts
|
||||
"translategroup" -> o =<< doTranslateGroup pgf # input % cat % to % limit
|
||||
"lookupmorpho" -> o =<< doLookupMorpho pgf # from1 % textInput
|
||||
"grammar" -> join $ doGrammar tpgf
|
||||
# liftIO (E.try (getLabels alc path pgf))
|
||||
% requestAcceptLanguage
|
||||
"abstrtree" -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree
|
||||
"alignment" -> outputGraphviz =<< alignment pgf # tree % to
|
||||
"parsetree" -> outputGraphviz =<< parseTree pgf # from1 % graphvizOptions % tree
|
||||
"deptree" -> join $ doDepTree lcs path pgf # format "dot" % to1 % 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 (const False)
|
||||
mlexer (Just lang) = lexer (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"
|
||||
% bool "nodep"
|
||||
% 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"
|
||||
|
||||
to1 = maybe (missing "to") return =<< getLang "to"
|
||||
to = (,) # getLangs "to" % unlexerH
|
||||
|
||||
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
|
||||
|
||||
full :: CGI Bool
|
||||
full = maybe False toBool # getInput "full"
|
||||
|
||||
-- * Request parameter access and related auxiliary functions
|
||||
|
||||
-}
|
||||
out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t
|
||||
setHeader "Last-Modified" fmt
|
||||
outputJSONP r
|
||||
@@ -563,228 +390,11 @@ 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 Concr,String)
|
||||
type To = ([Concr],Unlexer)
|
||||
type TreeOpts = (Bool,Bool) -- (trie,jsontree)
|
||||
{-
|
||||
doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> TreeOpts -> JSValue
|
||||
doTranslate pgf (mfrom,input) mcat tos mlimit (trie,jsontree) =
|
||||
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 (addTree jsontree tree++
|
||||
["linearizations".=
|
||||
[makeObj ["to".=to, "text".=text,
|
||||
"brackets".=bs]
|
||||
| (to,text,bs)<- linearizeAndUnlex 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 mlimit =
|
||||
showJSON
|
||||
[makeObj ["from".=langOnly (PGF.showLanguage from),
|
||||
"to".=langOnly (PGF.showLanguage to),
|
||||
"linearizations".=
|
||||
[toJSObject (("text",alt) : disamb lg from ts)
|
||||
| let lg = length output, (ts,alt) <- output]
|
||||
]
|
||||
|
|
||||
(from,po,bs) <- parse' pgf input mcat mfrom,
|
||||
(to,output) <- groupResults [(t, linearizeAndUnlex 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 [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 -> TreeOpts -> JSValue
|
||||
doParse pgf (mfrom,input) mcat mlimit (trie,jsontree) = 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".=trees']
|
||||
++["jsontrees".=map jsonExpr trees'|jsontree]
|
||||
++addTrie trie trees
|
||||
where trees' = maybe id take mlimit 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 -> Bool -> JSValue
|
||||
doComplete pgf (mfrom,input) mcat mlimit full = showJSON
|
||||
[makeObj (
|
||||
["from".=from, "brackets".=bs, "text".=s] ++
|
||||
if full
|
||||
then [ "completions" .= Map.elems (Map.mapWithKey (completionInfo pgf) cs) ]
|
||||
else [ "completions" .= Map.keys cs ]
|
||||
)
|
||||
| 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
|
||||
|
||||
completionInfo :: PGF -> PGF.Token -> [PGF.CId] -> JSValue
|
||||
completionInfo pgf token funs =
|
||||
makeObj
|
||||
["token".= token
|
||||
,"funs" .= map mkFun (nub funs)
|
||||
]
|
||||
where
|
||||
mkFun cid = case PGF.functionType pgf cid of
|
||||
Just typ ->
|
||||
makeObj [ {-"fid".=funid,-} "fun".=cid, "hyps".=hyps', "cat".=cat ]
|
||||
where
|
||||
(hyps,cat,_es) = PGF.unType typ
|
||||
hyps' = [ PGF.showType [] typ | (_,_,typ) <- hyps ]
|
||||
Nothing -> makeObj [ "error".=("Function "++show cid++" not found") ] -- shouldn't happen
|
||||
|
||||
doLinearize :: PGF -> PGF.Tree -> To -> JSValue
|
||||
doLinearize pgf tree tos = showJSON
|
||||
[makeObj ["to".=to, "text".=text,"brackets".=bs]
|
||||
| (to,text,bs) <- linearizeAndUnlex pgf tos tree]
|
||||
|
||||
doLinearizes :: PGF -> PGF.Tree -> To -> JSValue
|
||||
doLinearizes pgf tree (tos,unlex) = showJSON
|
||||
[makeObj ["to".=to, "texts".=map unlex 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 = showJSON
|
||||
[makeObj ["to".=to,
|
||||
"table".=[makeObj ["params".=ps,"texts".=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 =
|
||||
showJSON [makeObj ["tree".=PGF.showExpr [] tree,
|
||||
"linearizations".=
|
||||
[makeObj ["to".=to, "text".=text]
|
||||
| (to,text,bs) <- linearizeAndUnlex 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) -> Either IOError (UTCTime,l) -> Maybe (Accept Language) -> CGI CGIResult
|
||||
doGrammar (t1,pgf) elbls macc = out t $ showJSON $ makeObj
|
||||
["name".=PGF.abstractName pgf,
|
||||
"lastmodified".=show t,
|
||||
"hasDependencyLabels".=either (const False) (const True) elbls,
|
||||
"userLanguage".=selectLanguage pgf macc,
|
||||
"startcat".=PGF.showType [] (PGF.startCat pgf),
|
||||
"categories".=categories,
|
||||
"functions".=functions,
|
||||
"languages".=languages]
|
||||
where
|
||||
t = either (const t1) (max t1 . fst) elbls
|
||||
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
|
||||
@@ -800,48 +410,7 @@ outputGraphviz code =
|
||||
"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
|
||||
|
||||
doDepTree (alc,clc) path pgf fmt lang tree =
|
||||
do (_,lbls) <- liftIO $ getLabels alc path pgf
|
||||
clbls <- liftIO $ getCncLabels clc path pgf lang
|
||||
let vis = PGF.graphvizDependencyTree fmt False (Just lbls) clbls pgf lang tree
|
||||
if fmt `elem` ["png","gif","gv"]
|
||||
then outputGraphviz vis
|
||||
else if fmt=="svg"
|
||||
then outputText "image/svg+xml" vis
|
||||
else outputPlain vis
|
||||
|
||||
getLabels lc path pgf =
|
||||
msum [readCache' lc path | path<-[{-path1,-}path2,path3]]
|
||||
where
|
||||
dir = takeDirectory path
|
||||
--path1 = dir</> ...labels flag from abstract syntax...
|
||||
path2 = dir</>PGF.showCId (PGF.abstractName pgf)<.>"labels"
|
||||
path3 = dropExtension path <.> "labels"
|
||||
|
||||
getCncLabels lc path pgf lang =
|
||||
either fail ok =<< tryIO (readCache lc path2)
|
||||
where
|
||||
ok ls = do logError ("Found "++show (length ls)++" CncLabels for "++show lang++" in "++path2)
|
||||
return (Just ls)
|
||||
fail _ = do logError ("No CncLabels for "++show lang++" in "++path2)
|
||||
return Nothing
|
||||
dir = takeDirectory path
|
||||
--path1 = dir</> ...labels flag from concrete syntax...
|
||||
path2 = dir</>PGF.showCId lang<.>"labels"
|
||||
--path3 = ...
|
||||
|
||||
tryIO :: IO a -> IO (Either IOError a)
|
||||
tryIO = E.try
|
||||
|
||||
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) <-
|
||||
@@ -873,157 +442,10 @@ pipeIt2graphviz fmt code = do
|
||||
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 ]
|
||||
-}
|
||||
|
||||
<<<<<<< HEAD
|
||||
instance JSON Expr where
|
||||
readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . readExpr
|
||||
showJSON = showJSON . showExpr []
|
||||
=======
|
||||
class ToATree a where
|
||||
showTree :: a -> String
|
||||
toATree :: a -> PGF.ATree a
|
||||
|
||||
instance ToATree PGF.Expr where
|
||||
showTree = PGF.showExpr []
|
||||
toATree = PGF.toATree
|
||||
|
||||
-- | Render trees as JSON with numbered functions
|
||||
jsonExpr e = evalState (expr (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]
|
||||
readJSON = error "PGF.Trie.readJSON intentionally not defined"
|
||||
|
||||
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]
|
||||
>>>>>>> master
|
||||
|
||||
instance JSON BracketedString where
|
||||
readJSON x = return (Leaf "")
|
||||
@@ -1033,11 +455,6 @@ instance JSON BracketedString where
|
||||
|
||||
-- * PGF utilities
|
||||
|
||||
transfer lang = if "LaTeX" `isSuffixOf` show lang
|
||||
then fold -- OpenMath LaTeX transfer
|
||||
else id
|
||||
|
||||
<<<<<<< HEAD
|
||||
selectLanguage :: PGF -> Maybe (Accept Language) -> Concr
|
||||
selectLanguage pgf macc = case acceptable of
|
||||
[] -> case Map.elems (languages pgf) of
|
||||
@@ -1049,45 +466,6 @@ selectLanguage pgf macc = case acceptable of
|
||||
|
||||
langCodeLanguage :: PGF -> String -> Maybe Concr
|
||||
langCodeLanguage pgf code = listToMaybe [concr | concr <- Map.elems (languages pgf), languageCode concr == Just code]
|
||||
=======
|
||||
-- | tabulate all variants and their forms
|
||||
linearizeTabular
|
||||
:: PGF -> To -> PGF.Tree -> [(PGF.Language,[(String,[String])])]
|
||||
linearizeTabular pgf (tos,unlex) 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 unlex (nub [t|(p',t)<-vs,p'==p]))|p<-ps]
|
||||
where
|
||||
ps = nub (map fst vs)
|
||||
vs = concat (PGF.tabularLinearizes pgf to t)
|
||||
|
||||
linearizeAndUnlex pgf (mto,unlex) tree =
|
||||
[(to,s,bss) | to<-langs,
|
||||
let bss = PGF.bracketedLinearize pgf to (transfer to tree)
|
||||
s = unlex . unwords $ concatMap PGF.flattenBracketedString bss]
|
||||
where
|
||||
langs = if null mto then PGF.languages pgf else mto
|
||||
|
||||
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."
|
||||
ls@(l1:_) -> case [l | l<-ls, langPart pgf l==Just "Eng"] of
|
||||
eng:_ -> eng
|
||||
_ -> l1
|
||||
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]
|
||||
|
||||
langPart pgf lang =
|
||||
stripPrefix (PGF.showCId (PGF.abstractName pgf)) (PGF.showCId lang)
|
||||
>>>>>>> master
|
||||
|
||||
-- * General utilities
|
||||
|
||||
@@ -1096,7 +474,3 @@ infixl 2 #,%
|
||||
f .= v = (f,showJSON v)
|
||||
f # x = fmap f x
|
||||
f % x = ap f x
|
||||
|
||||
--cleanFilePath :: FilePath -> FilePath
|
||||
--cleanFilePath = takeFileName
|
||||
|
||||
|
||||
Reference in New Issue
Block a user