Use getOpt. Nicer local prompt. Terse mode.

darcs-hash:20070822192149-ec8c9-daedf68823ef1d3566c2f318f6ba7f7371a7bf86.gz

INSTALL.xhtml

@@ -54,6 +54,7 @@
       <li>Edit `config' to your liking.</li>
       <li><kbd>mkdir rt</kbd> # This will be our chroot root.</li>
       <li>scripts/compile-prelude # To produce rt/prelude.h.gch and a few rt/foo.o's.</li>
+      <li><kbd>cp res/terse.hpp rt/</kbd></li>
       <li><kbd>rtcp () { cp -L -r -v --parents $@ rt ; }</kbd></li>
       <li><kbd>libs () { echo `ldd $@ | grep -o -P "(?&lt;=\\s)/\\S*" | sort | uniq` ; }</kbd></li>
       <li><kbd>EXECS="`which g++ as ld strace` /usr/lib/gcc/i586-suse-linux/4.1.2/cc1plus"</kbd> # Correct the last one for your system.</li>
@@ -64,7 +65,7 @@
       <li><kbd>sudo chroot rt /a.out &amp;&amp; echo</kbd> # This may complain a bit more about missing libraries, which again should be copied into rt using rtcp. Eventually, it should print "9".</li>
       <li><kbd>sudo scripts/trace-execs</kbd></li>
       <li><kbd>find rt -perm -o+w</kbd> # This should list exactly four files: rt/t.o, rt/t.s, rt/t.cpp, and rt/t.</li>
-      <li><kbd>find rt -user nobody</kbd> # This should find no files at all.</li>
+      <li><kbd>find rt -user nobody</kbd> # This should find nothing.</li>
       <li><kbd>sudo ./Bot "geordi-clone &lt;&lt; 'x'"</kbd> # If this does not print 'x', something is messed up. (Replace "geordi-clone" with the configured nick, of course.)</li>
       <li>If you want, you can now <kbd>rm -f rt/usr/bin/strace rt/usr/bin/g++</kbd></li>
       <li>To get an idea of what rt could look like, look at the tree and file listing below.</li>

res/terse.hpp

@@ -0,0 +1,57 @@
+
+// Keywords:
+#define au auto
+#define brk break
+#define cat catch
+#define cexpr constexpr
+#define cls class
+#define co const
+#define dlt delete
+#define def default
+#define dtp decltype
+#define dub double
+#define dcast dynamic_cast
+#define expl explicit
+#define ext extern
+#define ff false
+#define flt float
+#define inl inline
+#define tpd typedef
+#define tpn typename
+#define mut mutable
+#define ns namespace
+#define op operator
+#define pub public
+#define pvt private
+#define prt protected
+#define reg register
+#define ret return
+#define rcast reinterpret_cast
+#define st struct
+#define stc static
+#define scast static_cast
+#define sass static_assert
+#define tmpl template
+#define tid typeid
+#define tt true
+#define use using
+#define vol volatile
+#define vrt virtual
+#define wh while
+// No need for #define uns unsigned, because we have uint/ulong/uchar typedefs.
+
+// Stdlib:
+#define ass assert
+#define iter iterator
+typedef ::std::string str;
+  // The following are to be replaced with template aliases at some point.
+#define vec ::std::vector
+#define umap ::std::unordered_map
+#define uset ::std::unordered_set
+#define numlim ::std::numeric_limits
+
+// Boost:
+#define lcast ::boost::lexical_cast
+#define foreach BOOST_FOREACH
+using boost::next;
+using boost::prior;

src/Bot.hs

@@ -1,23 +1,24 @@
 
 import Network (PortID(..), connectTo)
-import System.IO (hSetBuffering, BufferMode(..), hGetLine)
+import System.IO (hSetBuffering, BufferMode(..), hGetLine, hFlush, stdout)
 import System.Environment (getArgs)
 import System.Directory (setCurrentDirectory, getDirectoryContents)
 import System.Posix.Process (getProcessID)
 import System.Posix.Env (setEnv)
 import System.Posix.User
 import System.Posix.Resource
-import Control.Monad.Reader
+import Control.Monad.Error
 import Control.Monad
 import Text.ParserCombinators.Parsec
-import Prelude hiding (catch, (.), readFile, putStrLn, print)
+import Prelude hiding (catch, (.), readFile, putStrLn, putStr, print)
 import Data.Char
 import Data.List ((\\))
 import Data.Maybe
 import EvalCpp (evalCpp)
 import qualified EvalCpp
 import Util
 import System.IO.UTF8 hiding (hGetLine, getLine)
+import System.Console.GetOpt
 
 data BotConfig = BotConfig
   { server :: String, port :: Integer, max_msg_length :: Int
@@ -54,24 +55,40 @@ jail cfg = do
   setGroupID gid
   setUserID uid
 
-cmd_parser :: String -> CharParser st (Bool, String)
-cmd_parser [] = error "cannot have empty bot name"
-cmd_parser (botnick_h:botnick_t) = do
-  spaces
-  oneOf [toLower botnick_h, toUpper botnick_h]
-    -- There is currently no proper case-insensitive char/string comparison function in Data.Char (see GHC ticket #1506).
-  string botnick_t
-  spaces
-  also_run <- (string "-c" >> spaces >> return False) <|> return True
-  delimited <- (oneOf ":," >> spaces >> return True) <|> return False
-  let
-    wrapProgram c = "#include \"prelude.h\"\n" ++ c ++ "\n"
-    wrapPrePost t c = wrapProgram $ "GEORDI_" ++ t ++ "_PRE " ++ c ++ "\nGEORDI_" ++ t ++ "_POST"
-  code <- foldr1 (<|>) $
-    [ wrapPrePost "PRINT" . (string "<<" >> getInput),
-      wrapPrePost "STATEMENTS" . ('{':) . (char '{' >> getInput) ] ++
-    if delimited then [wrapProgram . getInput] else []
-  return (also_run, code)
+data Flag = CompileOnly | Terse | Help deriving (Eq, Enum, Bounded, Show)
+
+options :: [OptDescr Flag]
+options = (\e -> let s = toLower . show e in Option [head s] [s] (NoArg e) undefined) . [minBound ..]
+
+wrapPrePost :: String -> String -> String
+wrapPrePost t c = "GEORDI_" ++ t ++ "_PRE " ++ c ++ "\nGEORDI_" ++ t ++ "_POST"
+
+wrapPrint, wrapStmts :: String -> String
+wrapPrint = wrapPrePost "PRINT"
+wrapStmts = wrapPrePost "STATEMENTS"
+
+is_request :: String -> String -> Maybe String
+is_request botnick txt = either (const Nothing) Just (parse p "" txt)
+  where
+   p = do
+    string botnick <|> string (capitalize botnick)
+    (oneOf ":," >> getInput) <|> (spaces >> satisfy (not . isLetter) >>= \c -> (c:) . getInput)
+
+parse_request :: Monad m => String -> m (Bool {- also run -}, String {- code -})
+parse_request s = do
+  (opts, nonopcount) <- case getOpt RequireOrder options (words s) of
+    (_, _, (e:_)) -> fail e
+    (f, o, []) -> return (f, length o)
+  code <- if Help `elem` opts then return $ wrapPrint "help" else do
+    let u = concat $ takeBack nonopcount $ wordsWithWhite s
+    case stripPrefix "<<" u of
+      Just r -> return $ wrapPrint r
+      Nothing -> maybe (return u) (return . wrapStmts . ('{':)) (stripPrefix "{" u)
+  return (Help `elem` opts || not (CompileOnly `elem` opts),
+    unlines $ ["#include \"prelude.h\""] ++ (if Terse `elem` opts then ["#include \"terse.hpp\""] else []) ++ [code])
+
+prompt :: String
+prompt = "\n> "
 
 main :: IO ()
 main = do
@@ -87,19 +104,18 @@ main = do
   eval <- evalCpp
   args <- getArgs
   let
-    localEval l =
-      case parse (cmd_parser $ nick cfg) "" l of
-        Left e -> putStrLn $ "parse error: " ++ show e
-        Right (also_run, code) -> putStrLn =<< filter isPrint . eval code also_run
+    evalRequest :: String -> IO String
+    evalRequest = either return (\(also_run, code) -> filter isPrint . eval code also_run) . parse_request
+
   case args of
     ["-i"] -> do
       jail cfg
-      forever $ localEval =<< getLine
-    [] -> bot cfg eval
-    [c] -> jail cfg >> localEval c
+      forever $ putStr prompt >> hFlush stdout >> getLine >>= evalRequest >>= putStrLn
+    [] -> bot cfg evalRequest
+    [c] -> jail cfg >> evalRequest c >>= putStrLn
     _ -> fail "Invalid set of command line arguments."
 
-bot :: BotConfig -> (String -> Bool -> IO String) -> IO ()
+bot :: BotConfig -> (String -> IO String) -> IO ()
 bot cfg eval = withResource (connectTo (server cfg) (PortNumber (fromIntegral $ port cfg))) $ \h -> do
   setEnv "LC_ALL" "C" True -- Otherwise compiler warnings may use non-ASCII characters (e.g. for quotes).
   jail cfg
@@ -110,16 +126,14 @@ bot cfg eval = withResource (connectTo (server cfg) (PortNumber (fromIntegral $
   forever $ parse_irc_msg . init . liftIO (hGetLine h) >>= \m -> case m of
     IRCmsg _ "PING" a -> cmd "PONG" a
     IRCmsg (Just (IRCid fromnick _ _)) "PRIVMSG" [c, txt] ->
-      when (elem c (chans cfg) && not (elem fromnick $ blacklist cfg)) $ do
-        case parse (cmd_parser $ nick cfg) "" txt of
-          Left _ -> return () -- Parse error
-          Right (also_run, code) -> do
-            o <- take (max_msg_length cfg) . filter isPrint . takeWhile (/= '\n') . eval code also_run
-            cmd "PRIVMSG" [c, if null o then no_output_msg cfg else o]
+      when (elem c (chans cfg) && not (elem fromnick $ blacklist cfg)) $
+        maybeM (is_request (nick cfg) txt) $ \r -> do
+          o <- take (max_msg_length cfg) . filter isPrint . takeWhile (/= '\n') . eval r
+          cmd "PRIVMSG" [c, if null o then no_output_msg cfg else o]
     IRCmsg _ "376" {- End of motd. -} _ -> do
       forM_ (chans cfg) $ cmd "JOIN" . (:[])
       maybeM (nick_pass cfg) $ \np -> cmd "PRIVMSG" ["NickServ",  "identify " ++ np]
     _ -> return ()
 
--- (filter isPrint) works properly because (1) evalCpp returns a proper Unicode String, not a load of bytes; and (2) we use System.IO.UTF8's hPutStrLn which properly UTF-8 encodes the filtered String.
+-- (filter isPrint) works properly because (1) eval returns a proper Unicode String, not a load of bytes; and (2) we use System.IO.UTF8's hPutStrLn which properly UTF-8 encodes the filtered String.
 -- Possible problem: terminals which have not been (properly) UTF-8 configured might interpret bytes that are part of UTF-8 encoded characters as control characters.

src/Util.hs

@@ -4,15 +4,16 @@ module Util where
 import Foreign.C
 import Prelude hiding (catch, (.))
 import Data.List
+import Data.Char
 import Control.Exception
-import System.Posix.IO
 import Control.Monad
 import Control.Applicative
 import Control.Monad.Instances
 import System.Posix.Types
+import System.Posix.Resource
+import System.Posix.IO
 import System.IO
 import GHC.Read
-import System.Posix.Resource
 
 (.) :: Functor f => (a -> b) -> f a -> f b
 (.) = fmap
@@ -61,3 +62,20 @@ readTypedFile f = either (const $ fail $ "parsing \"" ++ f ++ "\"") return =<< r
 
 simpleResourceLimits :: Integer -> ResourceLimits
 simpleResourceLimits l = ResourceLimits (ResourceLimit l) (ResourceLimit l)
+
+stripPrefix :: String -> String -> Maybe String
+stripPrefix [] ys = Just ys
+stripPrefix (x:xs) (y:ys) | x == y = stripPrefix xs ys
+stripPrefix _ _ = Nothing
+
+capitalize :: String -> String
+capitalize "" = ""
+capitalize (x:xs) = toUpper x : xs
+
+takeBack :: Int -> [a] -> [a]
+takeBack n = reverse . take n . reverse
+
+wordsWithWhite :: String -> [String]
+wordsWithWhite "" = []
+wordsWithWhite s = (a ++ w) : wordsWithWhite s''
+  where (a,s') = break isSpace s; (w,s'') = span isSpace s'