pgf-hsbind-trans now with linearizeAll

1 files changed, 55 insertions, 0 deletions

diff --git a/src/runtime/haskell-bind/examples/pgf-hsbind-trans.hs b/src/runtime/haskell-bind/examples/pgf-hsbind-trans.hs
new file mode 100644
index 000000000..d04a96e08
--- /dev/null
+++ b/src/runtime/haskell-bind/examples/pgf-hsbind-trans.hs
@@ -0,0 +1,55 @@
+-- | pgf-hsbind-trans: A simple batch translator to illustrate the use of the Haskell binding
+--   to the C implementation of the PGF run-time system.
+--
+-- AR April 2015 modified from pgf-shell
+
+import PGF2
+import PGF.Lexing (lexText')
+
+import Data.Char(isSpace,toLower)
+import System.Environment
+import qualified Data.Map as Map
+
+maxNumTrees :: Int
+maxNumTrees = 1
+
+maxNumVariants :: Int
+maxNumVariants = 1
+
+main = getPGF =<< getArgs
+
+getPGF args = case args of
+  [path,from,to,cat,mxt,mxv] -> pgfTrans from to (Just cat) (read mxt, read mxv) =<< readPGF path
+  [path,from,to]        -> pgfTrans from to Nothing (maxNumTrees,maxNumVariants) =<< readPGF path
+  _                     -> putStrLn "Usage: pgf-hsbind-trans <path to pgf> <from-lang> <to-lang> [<cat> <#trees> <#variants>]"
+
+pgfTrans from to mcat mx pgf = do
+  cfrom <- getConcr' pgf from
+  cto   <- getConcr' pgf to
+  let cat = maybe (startCat pgf) id mcat
+  interact (unlines . map (translates pgf cfrom cto cat mx) . lines)
+
+getConcr' pgf lang =
+    maybe (fail $ "Concrete syntax not found: "++show lang) return $
+    Map.lookup lang (languages pgf)
+
+linearizeAndShow gr mxv (t,p) = [show t]++take mxv (linearizeAll gr t)++[show p]
+
+translates pgf cfrom cto cat (mxt,mxv) s0 = 
+  let s = lextext cfrom s0
+  in
+  case cparse pgf cfrom cat s of
+    Left tok -> unlines [s,"Parse error: "++tok]
+    Right ts -> unlines $ take mxt $ map (unlines . linearizeAndShow cto mxv) ts
+
+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]
+
+lextext cnc = unwords . lexText' (\w -> case lookupMorpho cnc w of
+  _:_ -> w
+  _ -> case lookupMorpho cnc (uncapitInit w) of 
+    [] -> w 
+    _ -> uncapitInit w
+  )
+ where uncapitInit (c:cs) = toLower c : cs