GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

Functions merge trees into tries in the GF Shell and the PGF web service

Browse Source 
* In the shell, the new command tt (to_trie) merges a list of trees into a
  trie and prints it in a readable way, where unique subtrees are marked with
  a "*" and alternative subtrees are marked with numbers.
* In the PGF web service, adding the parameter trie=yes to the parse and
  translate commands augments the JSON output with a trie.

Example to try in the shell:

	Phrasebook> p -lang=Eng "your son waits for you" | tt
This commit is contained in:
hallgren
2013-10-24 17:29:02 +00:00
parent 2aa5736cb4
commit ad0e67530b
3 changed files with 91 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
src/compiler/GF/Command/Commands.hs
View File

@@ -687,6 +687,12 @@ allCommands = Map.fromList [
("to", "forward-apply transliteration defined in this file")
]
}),
("tt", emptyCommandInfo {
longname = "to_trie",
syntax = "to_trie",
synopsis = "combine a list of trees into a trie",
exec = \ _ _ -> return . fromString . trie
}),
("pt", emptyCommandInfo {
longname = "put_tree",
syntax = "pt OPT? TREE",
@@ -1407,3 +1413,18 @@ execToktok (pgf, _) opts exprs = do
getLang [] = Nothing
getLang (OFlag "lang" (VId l):_) = readLanguage l
getLang (_:os) = getLang os
trie = render . pptss . toTrie . map toATree
where
pptss [ts] = text "*"<+>nest 2 (ppts ts)
pptss tss = vcat [int i<+>nest 2 (ppts ts)|(i,ts)<-zip [1..] tss]
ppts = vcat . map ppt
ppt t =
case t of
Oth e -> text (showExpr [] e)
Ap f [[]] -> text (showCId f)
Ap f tss -> text (showCId f) $$ nest 2 (pptss tss)

35
src/runtime/haskell/PGF.hs
View File

@@ -136,7 +136,9 @@ module PGF(
-- forExample,
-- * Browsing
browse
browse,
-- * Tries
ATree(..),Trie(..),toATree,toTrie
) where
import PGF.CId
@@ -328,3 +330,34 @@ browse pgf id = fmap (\def -> (def,producers,consumers)) definition
expIds (EFun id) ids = id : ids
expIds (ETyped e _) ids = expIds e ids
expIds _ ids = ids
-- | A type for plain applicative trees
data ATree = Other Tree | App CId [ATree] deriving Show
data Trie = Oth Tree | Ap CId [[Trie ]] deriving Show
-- ^ A type for tries of plain applicative trees
-- | Convert a 'Tree' to an 'ATree'
toATree :: Tree -> ATree
toATree e = maybe (Other e) app (unApp e)
where
app (f,es) = App f (map toATree es)
-- | Combine a list of trees into a trie
toTrie = combines . map ((:[]) . singleton)
where
singleton t = case t of
Other e -> Oth e
App f ts -> Ap f [map singleton ts]
combines [] = []
combines (ts:tss) = ts1:combines tss2
where
(ts1,tss2) = combines2 [] tss ts
combines2 ots [] ts1 = (ts1,reverse ots)
combines2 ots (ts2:tss) ts1 =
maybe (combines2 (ts2:ots) tss ts1) (combines2 ots tss) (combine ts1 ts2)
combine ts us = mapM combine2 (zip ts us)
where
combine2 (Ap f ts,Ap g us) | f==g = Just (Ap f (combines (ts++us)))
combine2 _ = Nothing

56
src/server/PGFService.hs
View File

@@ -59,14 +59,14 @@ cgiMain' cache path =
pgfMain :: String -> PGF -> CGI CGIResult
pgfMain command pgf =
case command of
"parse" -> out =<< doParse pgf # text % cat % from % limit
"parse" -> out =<< doParse pgf # text % cat % from % limit % trie
"complete" -> out =<< doComplete pgf # text % cat % from % limit
"linearize" -> out =<< doLinearize pgf # tree % to
"linearizeAll" -> out =<< doLinearizes pgf # tree % to
"linearizeTable" -> out =<< doLinearizeTabular pgf # tree % to
"random" -> cat >>= \c -> depth >>= \dp -> limit >>= \l -> to >>= \to -> liftIO (doRandom pgf c dp l to) >>= out
"generate" -> out =<< doGenerate pgf # cat % depth % limit % to
"translate" -> out =<< doTranslate pgf # text % cat % from % to % limit
"translate" -> out =<< doTranslate pgf # text % cat % from % to % limit % trie
"translategroup" -> out =<< doTranslateGroup pgf # text % cat % from % to % limit
"grammar" -> out =<< doGrammar pgf # requestAcceptLanguage
"abstrtree" -> outputGraphviz =<< abstrTree pgf # graphvizOptions % tree
@@ -129,6 +129,9 @@ pgfMain command pgf =
to :: CGI [PGF.Language]
to = getLangs "to"
trie :: CGI Bool
trie = maybe False toBool # getInput "trie"
getLangs :: String -> CGI [PGF.Language]
getLangs i = mapM readLang . maybe [] words =<< getInput i
@@ -162,7 +165,8 @@ pgfMain command pgf =
where
string name = maybe "" id # getInput name
bool name = maybe False toBool # getInput name
toBool s = s `elem` ["","yes","true","True"]
toBool s = s `elem` ["","yes","true","True"]
errorMissingId = throwCGIError 400 "Missing identifier" []
@@ -188,8 +192,8 @@ doExternal (Just cmd) input =
liftIO $ removeFile tmpfile2
return r
doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> JSValue
doTranslate pgf input mcat mfrom tos mlimit =
doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [PGF.Language] -> Maybe Int -> Bool -> JSValue
doTranslate pgf input mcat mfrom tos mlimit trie =
showJSON
[makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po)
| (from,po,bs) <- parse' pgf input mcat mfrom]
@@ -197,6 +201,7 @@ doTranslate pgf input mcat mfrom tos mlimit =
jsonTranslateOutput output =
case output of
PGF.ParseOk trees ->
addTrie trie trees++
["translations".=
[makeObj ["tree".=tree,
"linearizations".=
@@ -264,18 +269,22 @@ doTranslateGroup pgf input mcat mfrom tos mlimit =
notDisamb = (/="Disamb") . take 6 . PGF.showLanguage
doParse :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> JSValue
doParse pgf input mcat mfrom mlimit = showJSON $ map makeObj
doParse :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> Bool -> JSValue
doParse pgf input mcat mfrom 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 -> ["incomlete".=True]
PGF.ParseFailed n -> ["parseFailed".=n]
addTrie trie trees =
["trie".=map head (PGF.toTrie (map PGF.toATree trees))|trie]
doComplete :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> JSValue
doComplete pgf input mcat mfrom mlimit = showJSON
[makeObj ["from".=from, "brackets".=bs, "completions".=cs, "text".=s]
@@ -505,24 +514,31 @@ doBrowse pgf (Just id) cssClass href _ pn = -- default to "html" format
annotatePrintNames = "<DL>"++(unwords pns)++"</DL>"
where pns = ["<DT>"++(show lang)++"</DT><DD>"++(PGF.showPrintName pgf lang id)++"</DD>" | lang <- PGF.languages pgf ]
instance JSON PGF.CId where
readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage
showJSON = showJSON . PGF.showLanguage
jsonExpr e = evalState (expr e) 0
-- | Render trees as JSON with numbered functions
jsonExpr e = evalState (expr (PGF.toATree e)) 0
where
expr e = maybe other app (PGF.unApp e)
where
other = return (makeObj ["other".=e])
app (f,es) = do js <- mapM expr es
let children=["children".=js | not (null js)]
i<-inc
return $ makeObj (["fun".=f,"fid".=i]++children)
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 []