[command line UI created, not yet linked with Igor
martin.hofmann@uni-bamberg.de**20090331133741] adddir ./src/UI
addfile ./src/UI/REPLoop.hs
hunk ./src/UI/REPLoop.hs 1
-
+--
+-- Copyright (c) 2005 Lennart Augustsson
+-- See LICENSE for licensing details.
+--
+module UI.REPLoop(REPL(..), repl) where
+import Control.Monad.Error
+import System.Console.Editline.Readline(readline, addHistory)
+
+data REPL s = REPL {
+    repl_init :: IO (String, s),                -- prompt and initial state
+    repl_eval :: s -> String -> IO (Bool, s),           -- quit flag and new state
+    repl_exit :: s -> IO ()
+    }
+
+repl :: REPL s -> IO ()
+repl p = do
+    (prompt, state) <- repl_init p
+    let loop s = (do
+            mline <- readline prompt
+            case mline of
+                Nothing -> loop s
+                Just line -> do
+                    (quit, s') <- repl_eval p s line
+                    if quit then
+                        repl_exit p s'
+                     else do
+                        addHistory line
+                        loop s'
+            ) `catchError` ( \ err ->
+                do
+                    putStrLn $ "\nInterrupted (" ++ show err ++ ")"
+                    loop s
+            )
+    loop state
addfile ./src/UI/UIStarter.hs
hunk ./src/UI/UIStarter.hs 1
-
+
+module UI.UIStarter where
+
+import Text.ParserCombinators.Parsec
+import qualified Text.ParserCombinators.Parsec.Token as P
+import Text.ParserCombinators.Parsec.Language( emptyDef, LanguageDef(..) )
+import Control.Monad (when)
+import Control.Monad.Error (catchError, Error)
+
+import UI.REPLoop
+
+version :: String
+version = "version 0.5.2"
+
+prompt :: String
+prompt = "IgorII > "
+
+startUI :: IO ()
+startUI = do
+    let args' = []
+    let state = defaultState
+--    args <- getArgs
+--    let decodeOptions (('-':cs) : as) st = decodeOption cs >>= \f -> decodeOptions as (f False st)
+--        decodeOptions (('+':cs) : as) st = decodeOption cs >>= \f -> decodeOptions as (f True  st)
+--        decodeOptions as st = return (as, st)
+--        decodeOption cs = case [ set | (cmd, _, _, set) <- options, isPrefix cs cmd ] of
+--                          [] -> do usage; exitWith (ExitFailure 1)
+--                          set : _ -> return set
+--    (args', state) <- decodeOptions args startState
+    case args' of
+        [] -> repl (genRepl state)
+--        _ -> loop state args'
+--              where loop _ [] = return ()
+--                    loop s (a:as) = do
+--                        putStrLn $ "-- loading file " ++ a
+--                        (q, s') <- loadFile s a
+--                        if q then
+--                            return ()
+--                         else
+--                            loop s' as
+                            
+--usage :: IO ()
+--usage = putStrLn "Usage: igorII [option ...] [file ...]"
+
+genRepl :: EnvState -> REPL EnvState
+genRepl state = REPL {
+    repl_init = inIt state,
+    repl_eval = eval,
+    repl_exit = exit
+    }
+
+data EnvState = EState 
+    { verbose :: Bool
+    , debug :: Bool
+    , maxHypos :: Integer
+    }
+    deriving (Show)
+
+defaultState :: EnvState
+defaultState = EState
+    { verbose   = False
+    , debug     = True
+    , maxHypos  = 5
+    }   
+    
+inIt :: EnvState -> IO (String, EnvState)
+inIt state = do
+    putStrLn igorLogo
+    putStrLn $ "Welcome to IgorII " ++ version ++ "."
+    putStrLn $ "Type ':help' to get help."
+    return (prompt, state)
+
+eval :: EnvState -> String -> IO (Bool, EnvState)
+eval s line = 
+    case parseCmdLine line of
+        Right r  -> foldUntil runCmd s r
+        Left msg -> do{ putStrLn ("Unknown input " ++ msg) >>
+                        return (False, s)}
+
+
+exit :: EnvState -> IO ()
+exit _s = do
+    putStrLn "Bye."
+    return ()  
+
+runCmd :: EnvState -> Cmd -> IO (Bool, EnvState)
+runCmd s Noop = return (False, s)
+runCmd s Quit = return (True, s)
+runCmd s (Help verbose) = do
+    putStrLn $ helpText ++ unlines (map getHelp commands)
+    when verbose $ putStr verboseHelp
+    return (False, s)
+runCmd s (Set f) = return (False, f s) 
+runCmd s Info = putStrLn (getSettings s) >> return (False,s)
+runCmd s (Batch path) = loadBatch s path
+   
+foldUntil :: (Monad m) => (a -> b -> m (Bool,a)) -> a -> [b] -> m (Bool,a)
+foldUntil f state []     = return (False,state)
+foldUntil f state (l:ls) = do
+    qs@(q, state') <- f state l
+    if q then
+        return qs
+     else
+        foldUntil f state' ls
+                
+igorLogo :: String
+igorLogo = "\
+\.___                     .___.___                \n\
+\|   | ____   _____ ._____|   |   |    .__        \n\
+\|   |/ __ \\ /  __ \\|  __ \\   |   |  __|  |___ \n\ 
+\|   / /_/  X  /_/  )  | \\/   |   | /__    __/   \n\
+\|___\\___  / \\_____/|__|  |___|___|    |__|     \n\
+\   /_____/                                       \n\
+\"
+
+helpText :: String
+helpText = "\
+\\n\
+\Commands (may be abbreviated):\n\
+\"
+
+verboseHelp :: String
+verboseHelp = "\
+\Sorry, no verbose help yet!\n\
+\"
+
+getSettings :: EnvState -> String
+getSettings s = unlines $ 
+    [ "" , "Current settings" ] ++
+    [ "    " ++ (if gett s then "+" else "-") ++ name ++ replicate (20 - length name) ' ' ++ descr |
+                              (name, descr, gett, _set) <- flags ] ++
+    [""] ++
+    [ "    " ++ name ++ replicate (10 - length name) ' ' ++  " = " 
+             ++ show (getter s) ++ replicate (15 - length name) ' ' ++ descr |
+                              (name,descr,getter,_setter) <- options]
+      
+loadBatch :: EnvState -> String -> IO (Bool, EnvState)
+loadBatch s name = do
+    file <- readFile name
+    foldUntil eval s $ lines $ stripComments file
+
+-- strips comments '--' until the end of line '\n'
+stripComments :: String -> String
+stripComments "" = ""
+stripComments ('-':'-':cs) = skip cs
+  where skip "" = ""
+        skip s@('\n':_) = stripComments s
+        skip (_:s) = skip s
+stripComments (c:cs) = c : stripComments cs       
+
+--------------------------------------------------------------------------------
+-- Commands
+--------------------------------------------------------------------------------
+
+
+data Cmd
+ = Quit
+ | Noop
+ | Batch FilePath
+ | Load FilePath
+ | Set (EnvState -> EnvState)
+ | Info
+ | Help Bool    
+ 
+commands :: [(String, String, Parser Cmd)]
+commands =
+    [ (":help",                         "Print this message.",          return (Help False))
+    , (":verboseHelp",                  "Print verbose help.",          return (Help True))
+    , (":load \"path/to/file\"",        "Load a spec file",             stringLiteral >>= return . Load)
+    , (":batch \"path/to/file\"",       "Load a batch file",            stringLiteral >>= return . Batch)
+    , (":set <option>",                 "Set options",                  pSet)
+    , (":info",                         "Show current settings.",       return Info)
+    , (":quit",                         "Quit program.",                return Quit)
+--  ,("",                    "",                             return Noop)
+    ]
+    
+clipCommand :: String -> [String]
+clipCommand = (\s@(c:c':_) -> [(c:c':[]),s]) . head. words
+     
+getHelp :: (String, String, a) -> String
+getHelp (cmd, help, _) = cmd ++ replicate (25 - length cmd) ' ' ++ help
+
+flags :: [(String, String, EnvState->Bool, Bool->EnvState->EnvState)]
+flags = 
+    [ ("debug",             "debug mode",                   debug,  \ v s -> s { debug  = v })
+    , ("verbose",           "be verbose",                   verbose,  \ v s -> s { verbose  = v })
+    ] 
+    
+options :: [(String, String, EnvState->Integer, Integer->EnvState->EnvState)]
+options = 
+    [ ("maxHypos",           "maximal number of hypotheses", maxHypos,  \ v s -> s { maxHypos = v})
+    ] 
+           
+
+--------------------------------------------------------------------------------
+-- parsing commandline strings to commands
+--------------------------------------------------------------------------------
+
+-- my own token parser
+lexer :: P.TokenParser ()
+lexer = P.makeTokenParser
+         (emptyDef
+         { reservedNames   = concat [ clipCommand c| (c,_,_) <-  commands] ++
+                             [ f | (f,_,_,_) <-  flags]++
+                             [ o | (o,_,_,_) <-  options]
+         , reservedOpNames = [":",";","+","-","="]
+         })
+
+-- shortcuts         
+whiteSpace = P.whiteSpace lexer
+--parens     = P.parens lexer
+--semi       = P.semi lexer
+--colon      = P.colon lexer
+semiSep1   = P.semiSep1 lexer
+reserved   = P.reserved lexer
+reservedOp = P.reservedOp lexer
+stringLiteral     = P.stringLiteral lexer
+integer     = P.integer lexer
+
+parseCmdLine :: String -> Either String [Cmd]
+parseCmdLine line = 
+    case parse pBatch "" line of
+        Right r -> return r
+        Left er -> fail (show er)
+-- parser rules
+
+-- pBatch ::= pCommand (; pCommand)*
+pBatch :: Parser [Cmd]
+pBatch = do{ whiteSpace
+           ; x <- semiSep1 pCommand
+           ; eof
+           ; return x
+           }
+
+-- pCommand ::= eof | Quit | Help | ...
+pCommand :: Parser Cmd
+pCommand = do{ eof
+             ; return Noop
+             }
+       <|> choice [ do{ choice $ map reserved (clipCommand c) ; p} | 
+                                    (c,_,p) <- commands]
+       <?> "command"
+             
+pSet :: Parser Cmd
+pSet =  do cmds <-  many1 (choice [pFlag, pOption])
+           return $ foldl1 compose cmds
+    where
+    compose (Set f) (Set g) = Set (g . f)         
+         
+pFlag :: Parser Cmd
+pFlag = do{ reservedOp "+"
+          ; setter <- choice [ do{reserved f; return $ s True} | (f,_,_,s) <- flags]
+          ; return $ Set setter
+          }
+   <|> do{ reservedOp "-"
+          ; setter <- choice [ do{reserved f; return $ s False} | (f,_,_,s) <- flags]
+          ; return $ Set setter
+          }
+   <?> "[+|-]<flag>"             
+          
+pOption :: Parser Cmd
+pOption = do{ f <- choice [do{reserved o; return s} | (o,_,_,s) <- options]
+            ; reservedOp "="
+            ; i <- integer
+            ; return $ Set (f i)
+            }
+   <?> "<option>=<value>"
+
+            
+        
+
+         