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

PGF web service: add unlexers and enable client side caching

Browse Source 
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.
This commit is contained in:
hallgren
2014-04-09 17:51:25 +00:00
parent 50ea3d265c
commit d1da0e06de
3 changed files with 123 additions and 93 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
src/compiler/GFServer.hs
View File

@@ -15,7 +15,7 @@ import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory,
setCurrentDirectory,getCurrentDirectory, setCurrentDirectory,getCurrentDirectory,
getDirectoryContents,removeFile,removeDirectory, getDirectoryContents,removeFile,removeDirectory,
getModificationTime) getModificationTime)
import Data.Time (formatTime) import Data.Time (getCurrentTime,formatTime)
import System.Locale(defaultTimeLocale,rfc822DateFormat) import System.Locale(defaultTimeLocale,rfc822DateFormat)
import System.FilePath(dropExtension,takeExtension,takeFileName,takeDirectory, import System.FilePath(dropExtension,takeExtension,takeFileName,takeDirectory,
(</>)) (</>))
@@ -132,6 +132,7 @@ hmbracket_ pre post m =
-- | HTTP request handler -- | HTTP request handler
handle logLn documentroot state0 cache execute1 stateVar handle logLn documentroot state0 cache execute1 stateVar
rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) = rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) =
addDate $
case method of case method of
"POST" -> normal_request (utf8inputs body) "POST" -> normal_request (utf8inputs body)
"GET" -> normal_request (utf8inputs q) "GET" -> normal_request (utf8inputs q)
@@ -140,6 +141,12 @@ handle logLn documentroot state0 cache execute1 stateVar
logPutStrLn msg = liftIO $ logLn msg logPutStrLn msg = liftIO $ logLn msg
debug msg = logPutStrLn msg debug msg = logPutStrLn msg
addDate m =
do t <- getCurrentTime
r <- m
let fmt = formatTime defaultTimeLocale rfc822DateFormat t
return r{resHeaders=("Date",fmt):resHeaders r}
normal_request qs = normal_request qs =
do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs) do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs)
let stateful m = modifyMVar stateVar $ \ s -> run m (qs,s) let stateful m = modifyMVar stateVar $ \ s -> run m (qs,s)

9
src/server/Cache.hs
View File

@@ -1,4 +1,4 @@
module Cache (Cache,newCache,flushCache,readCache) where module Cache (Cache,newCache,flushCache,readCache,readCache') where
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Data.Map (Map) import Data.Map (Map)
@@ -21,7 +21,10 @@ flushCache :: Cache a -> IO ()
flushCache c = modifyMVar_ (cacheObjects c) (const (return Map.empty)) flushCache c = modifyMVar_ (cacheObjects c) (const (return Map.empty))
readCache :: Cache a -> FilePath -> IO a readCache :: Cache a -> FilePath -> IO a
readCache c file = readCache c file = snd `fmap` readCache' c file
readCache' :: Cache a -> FilePath -> IO (UTCTime,a)
readCache' c file =
do v <- modifyMVar (cacheObjects c) findEntry do v <- modifyMVar (cacheObjects c) findEntry
modifyMVar v readObject modifyMVar v readObject
where where
@@ -35,4 +38,4 @@ readCache c file =
x' <- case m of x' <- case m of
Just (t,x) | t' == t -> return x Just (t,x) | t' == t -> return x
_ -> cacheLoad c file _ -> cacheLoad c file
return (Just (t',x'), x') return (Just (t',x'), (t',x'))

196
src/server/PGFService.hs
View File

@@ -15,6 +15,8 @@ import qualified PGF2 as C
import Data.Time.Clock(UTCTime,getCurrentTime,diffUTCTime) import Data.Time.Clock(UTCTime,getCurrentTime,diffUTCTime)
#endif #endif
import Data.Time.Format(formatTime)
import System.Locale(defaultTimeLocale,rfc822DateFormat)
import Network.CGI import Network.CGI
import Text.JSON import Text.JSON
import Text.PrettyPrint as PP(render, text, (<+>)) import Text.PrettyPrint as PP(render, text, (<+>))
@@ -80,24 +82,24 @@ cgiMain' cache path =
"download" -> outputBinary =<< liftIO (BS.readFile path) "download" -> outputBinary =<< liftIO (BS.readFile path)
'c':'-':_ -> 'c':'-':_ ->
#ifdef C_RUNTIME #ifdef C_RUNTIME
cpgfMain command =<< liftIO (readCache (snd cache) path) cpgfMain command =<< liftIO (readCache' (snd cache) path)
#else #else
serverError "Server configured without C run-time support" "" serverError "Server configured without C run-time support" ""
#endif #endif
_ -> pgfMain command =<< liftIO (readCache (fst cache) path) _ -> pgfMain command =<< liftIO (readCache' (fst cache) path)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- * C run-time functionality -- * C run-time functionality
#ifdef C_RUNTIME #ifdef C_RUNTIME
cpgfMain :: String -> (C.PGF,MVar ParseCache) -> CGI CGIResult --cpgfMain :: String -> (C.PGF,MVar ParseCache) -> CGI CGIResult
cpgfMain command (pgf,pc) = cpgfMain command (t,(pgf,pc)) =
case command of case command of
"c-parse" -> out =<< join (parse # input % from % start % limit % trie) "c-parse" -> out t=<< join (parse # input % start % limit % trie)
"c-linearize" -> out =<< lin # tree % to "c-linearize" -> out t=<< lin # tree % to
"c-translate" -> out =<< join (trans#input%from%to%start%limit%trie) "c-translate" -> out t=<< join (trans # input % to % start % limit % trie)
"c-flush" -> out =<< flush "c-flush" -> out t=<< flush
"c-grammar" -> out grammar "c-grammar" -> out t grammar
_ -> badRequest "Unknown command" command _ -> badRequest "Unknown command" command
where where
flush = liftIO $ do modifyMVar_ pc $ const $ return Map.empty flush = liftIO $ do modifyMVar_ pc $ const $ return Map.empty
@@ -111,9 +113,8 @@ cpgfMain command (pgf,pc) =
where where
languages = [makeObj ["name".= l] | (l,_)<-Map.toList (C.languages pgf)] languages = [makeObj ["name".= l] | (l,_)<-Map.toList (C.languages pgf)]
parse input (from,concr) start mlimit trie = parse input@((from,_),_) start mlimit trie =
do lex <- c_lexer concr do r <- parse' start mlimit input
r <- parse' (from,concr) start mlimit (lex input)
return $ showJSON [makeObj ("from".=from:jsonParseResult r)] return $ showJSON [makeObj ("from".=from:jsonParseResult r)]
jsonParseResult = either bad good jsonParseResult = either bad good
@@ -122,7 +123,7 @@ cpgfMain command (pgf,pc) =
good trees = "trees".=map tp trees :[] -- :addTrie trie trees good trees = "trees".=map tp trees :[] -- :addTrie trie trees
tp (tree,prob) = makeObj ["tree".=tree,"prob".=prob] tp (tree,prob) = makeObj ["tree".=tree,"prob".=prob]
parse' (from,concr) start mlimit input = parse' start mlimit ((from,concr),input) =
liftIO $ do t <- getCurrentTime liftIO $ do t <- getCurrentTime
fmap (maybe id take mlimit . drop start) fmap (maybe id take mlimit . drop start)
# modifyMVar pc (parse'' t) # modifyMVar pc (parse'' t)
@@ -137,12 +138,12 @@ cpgfMain command (pgf,pc) =
purge r@(_,t') = if diffUTCTime t t'<120 then Just r else Nothing purge r@(_,t') = if diffUTCTime t t'<120 then Just r else Nothing
-- remove unused parse results after 2 minutes -- remove unused parse results after 2 minutes
lin tree tos = showJSON (lin' tree tos) lin tree to = showJSON (lin' tree to)
lin' tree tos = [makeObj ["to".=to,"text".=C.linearize c tree]|(to,c)<-tos] lin' tree (tos,unlex) =
[makeObj ["to".=to,"text".=unlex (C.linearize c tree)]|(to,c)<-tos]
trans input (from,concr) tos start mlimit trie = trans input@((from,_),_) to start mlimit trie =
do lex <- c_lexer concr do parses <- parse' start mlimit input
parses <- parse' (from,concr) start mlimit (lex input)
return $ return $
showJSON [ makeObj ["from".=from, showJSON [ makeObj ["from".=from,
"translations".= jsonParses parses]] "translations".= jsonParses parses]]
@@ -152,12 +153,18 @@ cpgfMain command (pgf,pc) =
bad err = [makeObj ["error".=err]] bad err = [makeObj ["error".=err]]
good parses = [makeObj ["tree".=tree, good parses = [makeObj ["tree".=tree,
"prob".=prob, "prob".=prob,
"linearizations".=lin' tree tos] "linearizations".=lin' tree to]
| (tree,prob) <- parses] | (tree,prob) <- parses]
from = maybe (missing "from") return =<< getLang "from" input = lexit # from % textInput
where
lexit (from,lex) input = (from,lex input)
to = getLangs "to" from = maybe (missing "from") getlexer =<< getLang "from"
where
getlexer f@(_,concr) = (,) f # c_lexer concr
to = (,) # getLangs "to" % unlexer
getLangs = getLangs' readLang getLangs = getLangs' readLang
getLang = getLang' readLang getLang = getLang' readLang
@@ -210,45 +217,59 @@ lexer' uncap = maybe (return id) lexerfun =<< getInput "lexer"
"mixed" -> return (unwords . lexMixed) "mixed" -> return (unwords . lexMixed)
_ -> badRequest "Unknown lexer" name _ -> 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 -- * Haskell run-time functionality
pgfMain :: String -> PGF -> CGI CGIResult --pgfMain :: String -> PGF -> CGI CGIResult
pgfMain command pgf = pgfMain command (t,pgf) =
case command of case command of
"parse" -> out =<< join (parse#input%cat%from%limit%trie) "parse" -> o =<< doParse pgf # input % cat % limit % trie
"complete" -> out =<< doComplete pgf # input % cat % from % limit "complete" -> o =<< doComplete pgf # input % cat % limit
"linearize" -> out =<< doLinearize pgf # tree % to "linearize" -> o =<< doLinearize pgf # tree % to
"linearizeAll" -> out =<< doLinearizes pgf # tree % to "linearizeAll" -> o =<< doLinearizes pgf # tree % to
"linearizeTable" -> out =<< doLinearizeTabular 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) >>= out "random" -> cat >>= \c -> depth >>= \dp -> limit >>= \l -> to >>= \to -> liftIO (doRandom pgf c dp l to) >>= o
"generate" -> out =<< doGenerate pgf # cat % depth % limit % to "generate" -> o =<< doGenerate pgf # cat % depth % limit % to
"translate" -> out =<< join (trans#input%cat%from%to%limit%trie) "translate" -> o =<< doTranslate pgf # input % cat % to % limit %trie
"translategroup" -> out =<< join (transgroup#input%cat%from%to%limit) "translategroup" -> o =<< doTranslateGroup pgf # input % cat % to % limit
"grammar" -> out =<< doGrammar pgf # requestAcceptLanguage "grammar" -> o =<< doGrammar pgf # requestAcceptLanguage
"abstrtree" -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree "abstrtree" -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree
"alignment" -> outputGraphviz =<< alignment pgf # tree % to "alignment" -> outputGraphviz =<< alignment pgf # tree % to
"parsetree" -> do t <- tree "parsetree" -> do t <- tree
Just l <- from Just l <- from
opts <- graphvizOptions opts <- graphvizOptions
outputGraphviz (parseTree pgf l opts t) outputGraphviz (parseTree pgf l opts t)
"abstrjson" -> out . jsonExpr =<< tree "abstrjson" -> o . jsonExpr =<< tree
"browse" -> join $ doBrowse pgf # optId % cssClass % href % format "html" % getIncludePrintNames "browse" -> join $ doBrowse pgf # optId % cssClass % href % format "html" % getIncludePrintNames
"external" -> do cmd <- getInput "external" "external" -> do cmd <- getInput "external"
doExternal cmd =<< input doExternal cmd =<< textInput
_ -> badRequest "Unknown command" command _ -> badRequest "Unknown command" command
where where
parse input cat from limit trie = o x = out t x
do lex <- mlexer from
return (doParse pgf (lex input) cat from limit trie)
trans input cat from to limit trie =
do lex <- mlexer from
return (doTranslate pgf (lex input) cat from to limit trie)
transgroup input cat from to limit =
do lex <- mlexer from
return (doTranslateGroup pgf (lex input) cat from to limit)
-- mlexer _ = lexer input = do fr <- from
lex <- mlexer fr
inp <- textInput
return (fr,lex inp)
mlexer Nothing = lexer
mlexer (Just lang) = ilexer (PGF.isInMorpho morpho) mlexer (Just lang) = ilexer (PGF.isInMorpho morpho)
where morpho = PGF.buildMorpho pgf lang where morpho = PGF.buildMorpho pgf lang
@@ -302,7 +323,7 @@ pgfMain command pgf =
bool name = maybe False toBool # getInput name bool name = maybe False toBool # getInput name
from = getLang "from" from = getLang "from"
to = getLangs "to" to = (,) # getLangs "to" % unlexer
getLangs = getLangs' readLang getLangs = getLangs' readLang
getLang = getLang' readLang getLang = getLang' readLang
@@ -316,15 +337,17 @@ pgfMain command pgf =
-- * Request parameter access and related auxiliary functions -- * Request parameter access and related auxiliary functions
out = outputJSONP --out = outputJSONP
out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t
setHeader "Last-Modified" fmt
outputJSONP r
getInput1 x = nonEmpty # getInput x getInput1 x = nonEmpty # getInput x
nonEmpty (Just "") = Nothing nonEmpty (Just "") = Nothing
nonEmpty r = r nonEmpty r = r
textInput :: CGI String
input :: CGI String textInput = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
input = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
getLangs' readLang i = mapM readLang . maybe [] words =<< getInput i getLangs' readLang i = mapM readLang . maybe [] words =<< getInput i
@@ -380,8 +403,10 @@ doExternal (Just cmd) input =
liftIO $ removeFile tmpfile2 liftIO $ removeFile tmpfile2
return r return r
doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> Bool -> JSValue type To = ([PGF.Language],Unlexer)
doTranslate pgf input mcat mfrom tos mlimit trie =
doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> Bool -> JSValue
doTranslate pgf (mfrom,input) mcat (tos,unlex) mlimit trie =
showJSON showJSON
[makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po) [makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po)
| (from,po,bs) <- parse' pgf input mcat mfrom] | (from,po,bs) <- parse' pgf input mcat mfrom]
@@ -393,7 +418,8 @@ doTranslate pgf input mcat mfrom tos mlimit trie =
["translations".= ["translations".=
[makeObj ["tree".=tree, [makeObj ["tree".=tree,
"linearizations".= "linearizations".=
[makeObj ["to".=to, "text".=text, "brackets".=bs] [makeObj ["to".=to, "text".=unlex text,
"brackets".=bs]
| (to,text,bs)<- linearizeAndBind pgf tos tree]] | (to,text,bs)<- linearizeAndBind pgf tos tree]]
| tree <- maybe id take mlimit trees]] | tree <- maybe id take mlimit trees]]
PGF.ParseIncomplete -> ["incomplete".=True] PGF.ParseIncomplete -> ["incomplete".=True]
@@ -405,13 +431,13 @@ jsonTypeErrors errs =
| (fid,err) <- errs]] | (fid,err) <- errs]]
-- used in phrasebook -- used in phrasebook
doTranslateGroup :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> JSValue doTranslateGroup :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> JSValue
doTranslateGroup pgf input mcat mfrom tos mlimit = doTranslateGroup pgf (mfrom,input) mcat (tos,unlex) mlimit =
showJSON showJSON
[makeObj ["from".=langOnly (PGF.showLanguage from), [makeObj ["from".=langOnly (PGF.showLanguage from),
"to".=langOnly (PGF.showLanguage to), "to".=langOnly (PGF.showLanguage to),
"linearizations".= "linearizations".=
[toJSObject (("text", doText alt) : disamb lg from ts) [toJSObject (("text",unlex alt) : disamb lg from ts)
| (ts,alt) <- output, let lg = length output] | (ts,alt) <- output, let lg = length output]
] ]
| |
@@ -430,16 +456,12 @@ doTranslateGroup pgf input mcat mfrom tos mlimit =
else (ts,y) : insertAlt t x xs2 else (ts,y) : insertAlt t x xs2
_ -> [([t],x)] _ -> [([t],x)]
doText s = case s of
c:cs | elem (last s) ".?!" -> toUpper c : init (init cs) ++ [last s]
_ -> s
langOnly = reverse . take 3 . reverse langOnly = reverse . take 3 . reverse
disamb lg from ts = disamb lg from ts =
if lg < 2 if lg < 2
then [] then []
else [("tree", "-- " ++ groupDisambs [doText (disambLang from t) | t <- ts])] else [("tree", "-- " ++ groupDisambs [unlex (disambLang from t) | t <- ts])]
groupDisambs = unwords . intersperse "/" groupDisambs = unwords . intersperse "/"
@@ -457,8 +479,10 @@ doTranslateGroup pgf input mcat mfrom tos mlimit =
notDisamb = (/="Disamb") . take 6 . PGF.showLanguage notDisamb = (/="Disamb") . take 6 . PGF.showLanguage
doParse :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> Bool -> JSValue type From = (Maybe PGF.Language,String)
doParse pgf input mcat mfrom mlimit trie = showJSON $ map makeObj
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".=from : "brackets".=bs : jsonParseOutput po
| (from,po,bs) <- parse' pgf input mcat mfrom] | (from,po,bs) <- parse' pgf input mcat mfrom]
where where
@@ -473,22 +497,22 @@ doParse pgf input mcat mfrom mlimit trie = showJSON $ map makeObj
addTrie trie trees = addTrie trie trees =
["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie] ["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie]
doComplete :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> JSValue doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> JSValue
doComplete pgf input mcat mfrom mlimit = showJSON doComplete pgf (mfrom,input) mcat mlimit = showJSON
[makeObj ["from".=from, "brackets".=bs, "completions".=cs, "text".=s] [makeObj ["from".=from, "brackets".=bs, "completions".=cs, "text".=s]
| from <- froms, let (bs,s,cs) = complete' pgf from cat mlimit input] | from <- froms, let (bs,s,cs) = complete' pgf from cat mlimit input]
where where
froms = maybe (PGF.languages pgf) (:[]) mfrom froms = maybe (PGF.languages pgf) (:[]) mfrom
cat = fromMaybe (PGF.startCat pgf) mcat cat = fromMaybe (PGF.startCat pgf) mcat
doLinearize :: PGF -> PGF.Tree -> [PGF.Language] -> JSValue doLinearize :: PGF -> PGF.Tree -> To -> JSValue
doLinearize pgf tree tos = showJSON doLinearize pgf tree (tos,unlex) = showJSON
[makeObj ["to".=to, "text".=text,"brackets".=bs] [makeObj ["to".=to, "text".=unlex text,"brackets".=bs]
| (to,text,bs) <- linearizeAndBind pgf tos tree] | (to,text,bs) <- linearizeAndBind pgf tos tree]
doLinearizes :: PGF -> PGF.Tree -> [PGF.Language] -> JSValue doLinearizes :: PGF -> PGF.Tree -> To -> JSValue
doLinearizes pgf tree tos = showJSON doLinearizes pgf tree (tos,unlex) = showJSON
[makeObj ["to".=to, "texts".=map doBind texts] [makeObj ["to".=to, "texts".=map (unlex . doBind) texts]
| (to,texts) <- linearizes' pgf tos tree] | (to,texts) <- linearizes' pgf tos tree]
where where
linearizes' pgf tos tree = linearizes' pgf tos tree =
@@ -497,29 +521,30 @@ doLinearizes pgf tree tos = showJSON
langs = if null tos then PGF.languages pgf else tos langs = if null tos then PGF.languages pgf else tos
lins to = nub . concatMap (map snd) . PGF.tabularLinearizes pgf to lins to = nub . concatMap (map snd) . PGF.tabularLinearizes pgf to
doLinearizeTabular :: PGF -> PGF.Tree -> [PGF.Language] -> JSValue doLinearizeTabular :: PGF -> PGF.Tree -> To -> JSValue
doLinearizeTabular pgf tree tos = showJSON doLinearizeTabular pgf tree (tos,unlex) = showJSON
[makeObj ["to".=to, [makeObj ["to".=to,
"table".=[makeObj ["params".=ps,"texts".=ts] | (ps,ts)<-texts]] "table".=[makeObj ["params".=ps,"texts".=map unlex ts]
| (ps,ts)<-texts]]
| (to,texts) <- linearizeTabular pgf tos tree] | (to,texts) <- linearizeTabular pgf tos tree]
doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> [PGF.Language] -> IO JSValue doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> To -> IO JSValue
doRandom pgf mcat mdepth mlimit tos = doRandom pgf mcat mdepth mlimit to =
do g <- newStdGen do g <- newStdGen
let trees = PGF.generateRandomDepth g pgf cat (Just depth) let trees = PGF.generateRandomDepth g pgf cat (Just depth)
return $ showJSON return $ showJSON
[makeObj ["tree".=PGF.showExpr [] tree, [makeObj ["tree".=PGF.showExpr [] tree,
"linearizations".= doLinearizes pgf tree tos] "linearizations".= doLinearizes pgf tree to]
| tree <- limit trees] | tree <- limit trees]
where cat = fromMaybe (PGF.startCat pgf) mcat where cat = fromMaybe (PGF.startCat pgf) mcat
limit = take (fromMaybe 1 mlimit) limit = take (fromMaybe 1 mlimit)
depth = fromMaybe 4 mdepth depth = fromMaybe 4 mdepth
doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> [PGF.Language] -> JSValue doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> To -> JSValue
doGenerate pgf mcat mdepth mlimit tos = doGenerate pgf mcat mdepth mlimit (tos,unlex) =
showJSON [makeObj ["tree".=PGF.showExpr [] tree, showJSON [makeObj ["tree".=PGF.showExpr [] tree,
"linearizations".= "linearizations".=
[makeObj ["to".=to, "text".=text] [makeObj ["to".=to, "text".=unlex text]
| (to,text,bs) <- linearizeAndBind pgf tos tree]] | (to,text,bs) <- linearizeAndBind pgf tos tree]]
| tree <- limit trees] | tree <- limit trees]
where where
@@ -567,7 +592,7 @@ abstrTree pgf opts tree = PGF.graphvizAbstractTree pgf opts' tree
parseTree pgf lang opts tree = PGF.graphvizParseTree pgf lang opts tree parseTree pgf lang opts tree = PGF.graphvizParseTree pgf lang opts tree
alignment pgf tree tos = PGF.graphvizAlignment pgf tos' tree alignment pgf tree (tos,unlex) = PGF.graphvizAlignment pgf tos' tree
where tos' = if null tos then PGF.languages pgf else tos where tos' = if null tos then PGF.languages pgf else tos
pipeIt2graphviz :: String -> String -> IO BS.ByteString pipeIt2graphviz :: String -> String -> IO BS.ByteString
@@ -791,16 +816,11 @@ linearizeTabular pgf tos tree =
linearizeAndBind pgf mto tree = linearizeAndBind pgf mto tree =
[(to,s,bss) | to<-langs, [(to,s,bss) | to<-langs,
let bss = PGF.bracketedLinearize pgf to (transfer to tree) let bss = PGF.bracketedLinearize pgf to (transfer to tree)
s = unwords . bind $ concatMap PGF.flattenBracketedString bss] s = unwords . bindTok $ concatMap PGF.flattenBracketedString bss]
where where
langs = if null mto then PGF.languages pgf else mto langs = if null mto then PGF.languages pgf else mto
doBind = unwords . bind . words doBind = unwords . bindTok . words
bind ws = case ws of
w : "&+" : u : ws2 -> bind ((w ++ u) : ws2)
"&+":ws2 -> bind ws2
w : ws2 -> w : bind ws2
_ -> ws
selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language
selectLanguage pgf macc = case acceptable of selectLanguage pgf macc = case acceptable of