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

3 files changed, 63 insertions, 53 deletions

diff --git a/Env.hs b/Env.hs
index 5c47815..29963b3 100644
--- a/Env.hs
+++ b/Env.hs
@@ -3,11 +3,12 @@ module Env where
 import Conf
 import State
 
-data Env = Env State Conf
+type Dispatch = String -> (String -> IO ()) -> Env -> IO ()
+data Env = Env State Conf Dispatch
 
 envGetInt :: String -> Env -> Int
-envGetInt key (Env _ conf) = getUnwrappedInt key conf
+envGetInt key (Env _ conf _) = getUnwrappedInt key conf
 
 envGet :: String -> Env -> String
-envGet key (Env _ conf) = getUnwrapped key conf
+envGet key (Env _ conf _) = getUnwrapped key conf
 
diff --git a/IRC.hs b/IRC.hs
index d1e4724..4a402c7 100644
--- a/IRC.hs
+++ b/IRC.hs
@@ -25,14 +25,14 @@ ircWrite h s t = do
    printf    "> %s %s\n" s t
    hPrintf h "%s %s\r\n" s t
 
-ircPrivmsg :: Handle -> IrcMessage -> Env -> String -> IO ()
-ircPrivmsg h msg (Env state conf) s = do
+ircPrivMsg :: Handle -> IrcMessage -> Env -> String -> IO ()
+ircPrivMsg h msg (Env state conf _) s = do
       if isMultiline s 
-         then ircPrivmsg' (lines s)
-         else ircPrivmsg' [s]
+         then ircPrivMsg' (lines s)
+         else ircPrivMsg' [s]
    where
-      ircPrivmsg' [] = return ()
-      ircPrivmsg' (x:xs) = 
+      ircPrivMsg' [] = return ()
+      ircPrivMsg' (x:xs) = 
          let maxMessageSize = 
                getUnwrappedInt "maxMessageSize" conf 
              receiver = 
@@ -46,13 +46,13 @@ ircPrivmsg h msg (Env state conf) s = do
                   ircWrite h "PRIVMSG" (receiver ++ " :" 
                         ++ "...this message has been cut to " 
                         ++ (show maxMessageSize) ++ " chars")
-                  ircPrivmsg' xs
+                  ircPrivMsg' xs
                else do
                   ircWrite h "PRIVMSG" (receiver ++ " :" ++ x)
-                  ircPrivmsg' xs
+                  ircPrivMsg' xs
 
 ircConnect :: Env -> IO ()
-ircConnect (Env state conf) = do
+ircConnect (Env state conf dispatch) = do
    ircChannel <- get "ircChannel" conf
    ircNick <- get "ircNick" conf
    ircPort <- get "ircPort" conf
@@ -62,7 +62,7 @@ ircConnect (Env state conf) = do
    hSetBuffering h NoBuffering
    ircWrite h "NICK" ircNick
    ircWrite h "USER" $ ircNick ++ " 0 * :" ++ ircUser
-   ircEvalLoop h (Env state { currentChannel = ircChannel } conf)
+   ircEvalLoop h (Env state { currentChannel = ircChannel } conf dispatch)
 
 ircEvalLoop :: Handle -> Env -> IO ()
 ircEvalLoop h env = forever $ do
@@ -85,45 +85,13 @@ ircEvalLoop h env = forever $ do
       pong x = ircWrite h "PONG" (':' : drop 6 x)
 
 ircEval :: Handle -> IrcMessage -> Env -> IO ()
-ircEval h msg env@(Env state _) = 
+ircEval h msg env@(Env state _ dispatch) = 
    case isCommand (clean msg) of
-      Just xs -> dispatch h xs msg env
-      Nothing -> ircEvalServerMessage (clean msg)
+      Just cmd -> dispatch cmd sendReplyMsg env
+      Nothing -> evalServerMessage (clean msg)
    where
       isCommand ('!':xs) = Just xs
       isCommand _ = Nothing
-      ircEvalServerMessage "+x" = ircWrite h "JOIN" (currentChannel state)
-      ircEvalServerMessage _ = putStrLn $ show msg
-
-data Command = Command String String (State -> IO ()) 
-instance Show Command where 
-   show (Command a b _) = a ++ " - " ++ b
-
-dispatch :: Handle -> String -> IrcMessage -> Env -> IO ()
-dispatch h cmd msg env@(Env state conf) = do
-   getLambda ("!" ++ cmd) state -- Eval the specific lambda function of 'command'
-      where
-         databaseFile = envGet "databaseFile" env
-         commands = [      
-            Command "!h" "Prints help" 
-               (\_ -> do { printHelp commands } ),
-            Command "!i" "Prints infos" 
-               (\_ -> do { sendMessage $ (envGet "name" env) 
-                  ++ " " ++ (envGet "version" env) ++ " (try !h)"} ),
-            Command "!p" "Prints current state" 
-               (\s -> do { sendMessage $ show s } ),
-            Command "!s" "Stores current state to file" 
-               (\s -> do { sendMessage "Storing current state"; stateSave databaseFile s; } ),
-            Command "!q" "quits"
-               (\s -> do { sendMessage "Good bye"; stateSave databaseFile s; exitWith ExitSuccess } ) 
-            ]
-         sendMessage = ircPrivmsg h msg env
-         printHelp = sendMessage . concat . showL 
-         getLambda x = let (Command _ _ c) = getCommand x in c
-         getDescr x = let (Command _ b _) = getCommand x in b
-         getCommand x = 
-               let command = [ (Command a b c) | (Command a b c) <- commands, a == x ]
-                in if length command == 0
-                     then getCommand "!i" 
-                     else head command
-
+      evalServerMessage "+x" = ircWrite h "JOIN" (currentChannel state)
+      evalServerMessage _ = putStrLn $ show msg
+      sendReplyMsg = ircPrivMsg h msg env
diff --git a/Main.hs b/Main.hs
index 50e9f44..60d522c 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,9 +1,13 @@
 module Main where
 
+import System
+
+import Cmd
 import Conf
+import Env
 import IRC
 import State
-import Env
+import Tools
 
 main :: IO ()	
 main = do
@@ -11,9 +15,46 @@ main = do
    databaseFile <- get "databaseFile" conf
    let state = stateLoad databaseFile
    state' <- state -- Extract State from the IO Monad 
-   ircConnect (Env state' conf)
+   ircConnect (Env state' conf dispatch)
 
 -- Shortcut
 r :: IO ()
 r = main
 
+dispatch :: Dispatch
+dispatch cmd sendMessage env@(Env state conf _) = 
+   getLambda ("!" ++ cmd) state 
+      where
+         printHelp = sendMessage . concat . showL 
+         getLambda x = let (Cmd _ _ c) = getCmd x in c
+         getDescr x = let (Cmd _ b _) = getCmd x in b
+         getCmd x = 
+               let command = [ (Cmd a b c) | (Cmd a b c) <- commands, a == x ]
+                in if length command == 0
+                     then getCmd "!i" 
+                     else head command
+
+         commands = [      
+            Cmd "!h" "Prints help" 
+               (\_ -> printHelp commands ),
+
+            Cmd "!i" "Prints infos" 
+               (\_ -> sendMessage $ (envGet "name" env) 
+                     ++ " " ++ (envGet "version" env) 
+                     ++ " (try !h)" ),
+
+            Cmd "!p" "Prints current state" 
+               (\s -> sendMessage $ show s ),
+
+            Cmd "!s" "Stores current state to file" 
+               (\s -> do 
+                     sendMessage "Storing current state"
+                     stateSave (envGet "databaseFile" env) s ),
+
+            Cmd "!q" "quits"
+               (\s -> do
+                     sendMessage "Good bye"
+                     stateSave (envGet "databaseFile" env) s
+                     exitWith ExitSuccess ) 
+            ]
+