diff options
Diffstat (limited to 'src/runtime')
| -rw-r--r-- | src/runtime/haskell-bind/examples/ext-pgf-shell.hs | 192 |
1 files changed, 0 insertions, 192 deletions
diff --git a/src/runtime/haskell-bind/examples/ext-pgf-shell.hs b/src/runtime/haskell-bind/examples/ext-pgf-shell.hs deleted file mode 100644 index 23c4edb4e..000000000 --- a/src/runtime/haskell-bind/examples/ext-pgf-shell.hs +++ /dev/null @@ -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 |