forked from GitHub/gf-core
simplified the example translator and renamed it to pgf-hsbind-trans
This commit is contained in:
aarne
@@ -1,192 +0,0 @@
|
||||
-- | pgf-shell: A simple shell to illustrate the use of the Haskell binding
|
||||
-- to the C implementation of the PGF run-time system.
|
||||
--
|
||||
-- lib/src$
|
||||
-- make -j TranslateEng.pgf TranslateFre.pgf
|
||||
-- make TranslateEngFre
|
||||
--
|
||||
-- src/runtime/haskell-bind/examples
|
||||
-- ghc --make ext-pgf-shell.hs
|
||||
-- ./ext-pgf-shell ~/GF/lib/src/TranslateEngFre.pgf
|
||||
|
||||
-- The shell has 3 commands:
|
||||
--
|
||||
-- * parse: p <lang> <text>
|
||||
-- * linearize: l <lang> <tree>
|
||||
-- * translate: t <lang> <lang> <text>
|
||||
-- AR 15/4/2015: extended functionality:
|
||||
-- call the program with
|
||||
-- ./ext-pgf-shell <pgf-file> <from-concrete-name> <to-concrete-name>
|
||||
-- then you can translate text files line by line, and see the top-20 trees with their translations and probabilities.
|
||||
-- 20 = maxNumTrees, which can be changed
|
||||
|
||||
import Control.Monad(forever)
|
||||
import Control.Monad.State(evalStateT,put,get,gets,liftIO)
|
||||
import Control.Exception.Lifted as L(catch)
|
||||
import Data.Char(isSpace)
|
||||
import qualified Data.Map as M
|
||||
import System.IO(hFlush,stdout)
|
||||
import System.Environment
|
||||
import PGF2
|
||||
import System.Mem(performGC)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
maxNumTrees :: Int
|
||||
maxNumTrees = 20
|
||||
|
||||
main = getPGF =<< getArgs
|
||||
|
||||
getPGF [path,from,to] = pgfShell from to =<< readPGF path
|
||||
getPGF [path] = pgfShell english french =<< readPGF path
|
||||
getPGF _ = putStrLn "Usage: pgf-shell <path to pgf>"
|
||||
|
||||
pgfShell from to pgf =
|
||||
do putStrLn . unwords . M.keys $ languages pgf
|
||||
putStrLn $ unwords ["default translation direction:",from,to]
|
||||
flip evalStateT (pgf,[]) $ forever $ do liftIO performGC
|
||||
puts "> "; liftIO $ hFlush stdout
|
||||
execute from to =<< liftIO readLn
|
||||
|
||||
execute from to cmd =
|
||||
case cmd of
|
||||
L lang tree -> do pgf <- gets fst
|
||||
c <- getConcr' pgf lang
|
||||
put (pgf,[])
|
||||
putln $ linearize c tree
|
||||
P lang s -> do pgf <- gets fst
|
||||
c <- getConcr' pgf lang
|
||||
case parse c (startCat pgf) s of
|
||||
Left tok -> do put (pgf,[])
|
||||
putln ("Parse error: "++tok)
|
||||
Right ts -> do put (pgf,map show ts)
|
||||
pop
|
||||
T from to s -> do pgf <- gets fst
|
||||
cfrom <- getConcr' pgf from
|
||||
cto <- getConcr' pgf to
|
||||
case parse cfrom (startCat pgf) s of
|
||||
Left tok -> do put (pgf,[])
|
||||
putln ("Parse error: "++tok)
|
||||
Right ts -> do put (pgf,map (linearize cto.fst) ts)
|
||||
pop
|
||||
A ss -> do pgf <- gets fst -- AR
|
||||
cfrom <- getConcr' pgf from
|
||||
cto <- getConcr' pgf to
|
||||
translatesWithPron pgf cfrom cto (startCat pgf) [] ss
|
||||
E s -> do pgf <- gets fst -- AR
|
||||
cfrom <- getConcr' pgf from
|
||||
cto <- getConcr' pgf to
|
||||
translates pgf cfrom cto (startCat pgf) [] s
|
||||
I path -> do pgf <- liftIO (readPGF path)
|
||||
putln . unwords . M.keys $ languages pgf
|
||||
put (pgf,[])
|
||||
Empty -> pop
|
||||
Unknown s -> putln ("Unknown command: "++s)
|
||||
`L.catch` (liftIO . print . (id::IOError->IOError))
|
||||
|
||||
pop = do (pgf,ls) <- get
|
||||
let (ls1,ls2) = splitAt 1 ls
|
||||
putl ls1
|
||||
put (pgf,ls2)
|
||||
|
||||
getConcr' pgf lang =
|
||||
maybe (fail $ "Concrete syntax not found: "++show lang) return $
|
||||
Map.lookup lang (languages pgf)
|
||||
|
||||
printl xs = liftIO $ putl $ map show xs
|
||||
putl ls = liftIO . putStr $ unlines ls
|
||||
putln s = liftIO $ putStrLn s
|
||||
puts s = liftIO $ putStr s
|
||||
|
||||
-- | Abstracy syntax of shell commands
|
||||
data Command = P String String | L String Expr | T String String String
|
||||
| I FilePath | Empty | Unknown String
|
||||
| A [String] -- AR
|
||||
| E String -- AR
|
||||
deriving Show
|
||||
|
||||
-- | Shell command parser
|
||||
instance Read Command where
|
||||
readsPrec _ s =
|
||||
take 1 $
|
||||
[(P l r2,"") | ("p",r1)<-lex s, (l,r2) <- lex r1]
|
||||
++ [(L l t,"") | ("l",r1)<-lex s, (l,r2)<- lex r1, Just t<-[readExpr r2]]
|
||||
++ [(T l1 l2 r3,"") | ("t",r1)<-lex s, (l1,r2)<-lex r1, (l2,r3)<-lex r2]
|
||||
++ [(I (dropWhile isSpace r),"") | ("i",r)<-lex s]
|
||||
++ [(Empty,"") | ("","") <- lex s]
|
||||
++ [(E s,"")] -- translation with treebank output
|
||||
++ [(A (chop s),"")] -- Liza's application
|
||||
++ [(Unknown s,"")]
|
||||
|
||||
|
||||
-- extensions AR 9/4/2015
|
||||
|
||||
-- the main function
|
||||
changeTree :: [Expr] -> (Expr,a) -> (Expr,a)
|
||||
changeTree context (t,a) = (change t,a) where
|
||||
change t = maybe t trans $ unApp t
|
||||
trans (fun,args) = case (fun,args) of
|
||||
("it_Pron",[]) -> case givenNouns context of
|
||||
n:_ -> mkApp "AnnotPron" [n]
|
||||
_ -> mkApp "she_Pron" []
|
||||
_ -> mkApp fun (map change args)
|
||||
|
||||
givenNouns :: [Expr] -> [Expr]
|
||||
givenNouns = concatMap getNouns where
|
||||
getNouns t = case unApp t of
|
||||
Just ("UseN",[n]) -> [n]
|
||||
Just (_,ts) -> concatMap getNouns ts
|
||||
_ -> []
|
||||
|
||||
english = "TranslateEng"
|
||||
french = "TranslateFre"
|
||||
|
||||
linearizeAndShow gr (t,p) = [show t, linearize gr t, show p]
|
||||
-- put (pgf,map show ts')
|
||||
-- put (pgf,map (linearize cto.fst) ts')
|
||||
|
||||
|
||||
selectTrees :: [(Expr,a)] -> [(Expr,a)]
|
||||
selectTrees ts = case filter notChunk (take 10 ts) of
|
||||
[] -> ts
|
||||
ncts -> ncts
|
||||
where
|
||||
notChunk (t,_) = case unApp t of
|
||||
Just ("ChunkPhr",_) -> False
|
||||
_ -> True
|
||||
|
||||
chop :: String -> [String]
|
||||
chop s = case break (==';') s of
|
||||
(s1,_:s2) -> s1 : chop s2
|
||||
_ -> [s]
|
||||
|
||||
translates pgf cfrom cto cat context s = do
|
||||
putln s
|
||||
case cparse pgf cfrom cat s of
|
||||
Left tok -> do
|
||||
-- put (pgf,[])
|
||||
putln ("Parse error: "++tok)
|
||||
Right ts -> do
|
||||
let ls = map (unlines . linearizeAndShow cto) ts
|
||||
-- put (pgf,ls)
|
||||
putln (unlines $ take maxNumTrees ls)
|
||||
put (pgf,[])
|
||||
|
||||
translatesWithPron pgf cfrom cto cat context ss = case ss of
|
||||
[] -> put (pgf,[])
|
||||
s:rest -> case cparse pgf cfrom cat s of
|
||||
Left tok -> do
|
||||
put (pgf,[])
|
||||
putln ("Parse error: "++tok)
|
||||
Right ts -> do
|
||||
let ts' = map (changeTree context) (selectTrees ts)
|
||||
put (pgf,map (unlines . init . linearizeAndShow cto) ts')
|
||||
pop
|
||||
translatesWithPron pgf cfrom cto cat (fst (head ts') : context) rest
|
||||
|
||||
cparse pgf concr cat input = parseWithHeuristics concr cat input (-1) callbacks where
|
||||
callbacks = maybe [] cb $ lookup "App" literalCallbacks
|
||||
cb fs = [(cat,f pgf ("TranslateEng",concr))|(cat,f)<-fs]
|
||||
|
||||
|
||||
-- to do
|
||||
-- actual selection in changeTree
|
||||
Reference in New Issue
Block a user