git-svn-id: https://ssl.buetow.org/repos/hsbot/trunk@41 9f8f72e9-4bf4-416e-b76e-7d4203597157

3 files changed, 35 insertions, 33 deletions

diff --git a/Env.hs b/Env.hs
index 5064392..bb6a0b8 100644
--- a/Env.hs
+++ b/Env.hs
@@ -3,7 +3,7 @@ module Env where
 import Conf
 import State
 
-type Dispatch = String -> (String -> IO ()) -> Env -> IO ()
+type Dispatch = String -> (String -> IO ()) -> Env -> IO Env
 data Env = DispatchEnv State Conf Dispatch | Env State Conf
 
 castEnv :: Env -> Env
diff --git a/IRC.hs b/IRC.hs
index fab7acb..6bf94ff 100644
--- a/IRC.hs
+++ b/IRC.hs
@@ -70,28 +70,27 @@ ircEvalLoop h env = do
       env' <- branch s
       ircEvalLoop h env'
    where 
-      branch s = if ping s then do { pong s; return (env) } else ircEval h msg env
-         where 
-            ping x = "PING :" `isPrefixOf` x
-            pong x = ircWrite h "PONG" (':' : drop 6 x)
-            from = drop 1 . takeWhile (/= '!') 
-            clean = drop 1 . dropWhile (/= ':') . drop 1
-            isQuery x = split x ' ' !! 2 == (envGet "ircNick" env)
-            msg = IrcMessage { raw = s, from = from s, clean = clean s, isQuery = isQuery s }
+      branch s 
+         | ping s = do { pong s; return (env) }
+         | otherwise = ircEval h (msg s) env
+      ping x = "PING :" `isPrefixOf` x
+      pong x = ircWrite h "PONG" (':' : drop 6 x)
+      from = drop 1 . takeWhile (/= '!') 
+      clean = drop 1 . dropWhile (/= ':') . drop 1
+      isQuery x = split x ' ' !! 2 == (envGet "ircNick" env)
+      msg s = IrcMessage { 
+         raw = s, from = from s, 
+         clean = clean s, isQuery = isQuery s
+      }
 
 ircEval :: Handle -> IrcMessage -> Env -> IO Env
-ircEval h msg env@(DispatchEnv state _ dispatch) = 
-   case isCommand (clean msg) of
-      Just cmd -> do
-         dispatch cmd sendReplyMsg (castEnv env)
-         return (env)
-      Nothing -> do
-         evalMessage (clean msg)
-         return (env)
+ircEval h msg env@(DispatchEnv state _ dispatch) = ircEval' (clean msg)
    where
-      isCommand ('!':xs) = Just xs
-      isCommand _ = Nothing
-      evalMessage "+x" = ircWrite h "JOIN" (currentChannel state)
-      evalMessage _ = putStrLn $ "foo" ++ (show msg)
+      ircEval' "+x" = do
+         ircWrite h "JOIN" (currentChannel state)
+         return (env)
+      ircEval' cleanMsg = do
+         (Env s c) <- dispatch cleanMsg sendReplyMsg (castEnv env)
+         return (DispatchEnv s c dispatch)
       sendReplyMsg = ircPrivMsg h msg (castEnv env)
 
diff --git a/Main.hs b/Main.hs
index 1d668d3..df2c41b 100644
--- a/Main.hs
+++ b/Main.hs
@@ -22,30 +22,33 @@ r :: IO ()
 r = main
 
 dispatch :: Dispatch
-dispatch cmd sendMessage env@(Env state conf) = 
-   let commands = [      
+dispatch msg sendMessage env@(Env state conf) = dispatch' msg
+   where
+      dispatch' ('!':_) = 
+         case cmdGet msg commands of
+           Just (Cmd _ _ cmdAction) -> do
+              cmdAction state
+              return (env)
+           Nothing -> return (env)
+      dispatch' _ = return (env)
+      commands = [      
          Cmd "!h" "Prints help" printHelp,
          Cmd "!i" "Prints infos" printInfos,
          Cmd "!p" "Prints current state" printState, 
          Cmd "!s" "Stores current state to file" storeState,
          Cmd "!q" "quits" quit
          ]
-       printHelp _ = printHelp' commands
+      printHelp _ = printHelp' commands
          where printHelp' = sendMessage . concat . showL 
-       printInfos _ = do
+      printInfos _ = do
          sendMessage $ (envGet "name" env) 
             ++ " " ++ (envGet "version" env) 
             ++ " (try !h)"
-       printState = sendMessage . show
-       storeState state = do
+      printState = sendMessage . show
+      storeState state = do
          sendMessage "Storing current state"
          stateSave (envGet "databaseFile" env) state
-       quit state = do
+      quit state = do
          sendMessage "Good bye"
          stateSave (envGet "databaseFile" env) state
          exitWith ExitSuccess 
-
-   in case cmdGet ("!" ++ cmd) commands of
-      Just (Cmd _ _ cmdAction) -> cmdAction state
-      Nothing -> return ()
-