1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
-- | 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
|
