remove the old Haskell runtime

src/runtime/haskell/examples/pgf-shell.hs

@@ -0,0 +1,87 @@
+-- | pgf-shell: A simple shell to illustrate the use of the Haskell binding
+--   to the C implementation of the PGF run-time system.
+--
+--   The shell has 4 commands:
+--
+--     * parse: p <lang> <text>
+--     * linearize: l <lang> <tree>
+--     * translate: t <lang> <lang> <text> 
+--     * import: i <path to pgf>
+
+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 qualified Data.Map as Map
+
+main = getPGF =<< getArgs
+
+getPGF [path] = pgfShell =<< readPGF path
+getPGF _ = putStrLn "Usage: pgf-shell <path to pgf>"
+
+pgfShell pgf =
+  do putStrLn . unwords . M.keys $ languages pgf
+     flip evalStateT (pgf,[]) $ forever $ do puts "> "; liftIO $ hFlush stdout
+                                             execute =<< liftIO readLn
+
+execute 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
+                        ParseFailed _ tok -> do put (pgf,[])
+                                                putln ("Parse error: "++tok)
+                        ParseOk 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
+                        ParseFailed _ tok -> do put (pgf,[])
+                                                putln ("Parse error: "++tok)
+                        ParseOk ts        -> do put (pgf,map (linearize cto.fst) ts)
+                                                pop
+    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
+             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]
+       ++ [(Unknown s,"")]