Permalink
Browse files

Replace monads-fd with mtl

Some cleanups
  • Loading branch information...
1 parent 0ae4231 commit 18a33583517706e0e2b5676de2d5bbf19a8c3b39 Jonas Westerlund committed Dec 14, 2012
Showing with 33 additions and 40 deletions.
  1. +1 −1 norby.cabal
  2. +17 −23 src/Commands.hs
  3. +8 −8 src/Eval.hs
  4. +7 −8 src/Messages.hs
View
@@ -28,7 +28,7 @@ executable norby
build-depends: base-unicode-symbols >= 0.2 && < 1.0
build-depends: bytestring >= 0.9 && < 1.0
build-depends: hint >= 0.3 && < 1.0
- build-depends: monads-fd >= 0.1 && < 1.0
+ build-depends: mtl >= 2.0 && < 3.0
build-depends: network >= 2.3 && < 3.0
build-depends: parsec >= 3.0 && < 4.0
build-depends: process >= 1.0 && < 2.0
View
@@ -3,7 +3,6 @@
module Commands where
-import Control.Monad (ap)
import Control.Monad.Reader (liftIO)
import Data.ByteString hiding (drop, last)
import Data.Maybe
@@ -35,64 +34,59 @@ handlers = [ connectHandler
-- Helper funtion for performing an action if the last parameter of a message
-- (e.g. the text portion of a PRIVMSG) matches a certain prefix.
-whenPrefix Monad m ByteString Message (Message m ()) m ()
+whenPrefix Monad m ByteString Message (Params m ()) m ()
whenPrefix pfx msg act =
case msg of
(Message (Just (User _ _ _)) _ ps@(_:_))
- if pfx `isPrefixOf` last ps then act msg else return ()
+ if pfx `isPrefixOf` last ps then act ps else return ()
_ return ()
-- Same as `whenPrefix`, but checks for admin priviliges.
-whenPrefixAdmin Monad m ByteString Message (Message m ()) m ()
+whenPrefixAdmin Monad m ByteString Message (Params m ()) m ()
whenPrefixAdmin pfx msg act =
case msg of
(Message (Just (User nn _ _)) _ ps@(_:_))
- if pfx `isPrefixOf` last ps nn admins then act msg else return ()
+ if pfx `isPrefixOf` last ps nn admins then act ps else return ()
_ return ()
-- Performs an action if the command part of a message matches the argument.
-whenCommand Monad m ByteString Message (Message m ()) m ()
-whenCommand cmd msg@(Message _ cmd' _) act =
- if cmd cmd' then act msg else return ()
+whenCommand Monad m ByteString Message (Params m ()) m ()
+whenCommand cmd (Message _ cmd' ps) act =
+ if cmd cmd' then act ps else return ()
connectHandler Message Net ()
connectHandler msg = whenCommand "001" msg const join $ intercalate "," channels
evalHandler Message Net ()
-evalHandler msg = whenPrefix "> " msg $ ap ((≫=) liftIO evalHsExt) replyTo
+evalHandler msg = whenPrefix "> " msg $ (reply msg =≪) liftIO evalHsExt
inviteHandler Message Net ()
-inviteHandler msg = whenCommand "INVITE" msg $
- \(Message _ _ ps) join concat $ drop 1 ps
+inviteHandler msg = whenCommand "INVITE" msg $ join concat drop 1
joinHandler Message Net ()
-joinHandler msg = whenPrefixAdmin "'join" msg $
- \(Message _ _ ps) join nthWord 2 $ last ps
+joinHandler msg = whenPrefixAdmin "'join" msg $ join nthWord 2 last
partHandler Message Net ()
-partHandler msg = whenPrefixAdmin "'part" msg $
- \(Message _ _ ps) part nthWord 2 $ last ps
+partHandler msg = whenPrefixAdmin "'part" msg $ part nthWord 2 last
pingHandler Message Net ()
-pingHandler msg = whenCommand "PING" msg $
- \(Message _ _ p) write $ Message Nothing "PONG" p
+pingHandler msg = whenCommand "PING" msg $ write Message Nothing "PONG"
pointFreeHandler Message Net ()
-pointFreeHandler msg = whenPrefix "'pf" msg $ ap ((≫=) liftIO pointFree) replyTo
+pointFreeHandler msg = whenPrefix "'pf" msg $ (reply msg =≪) liftIO pointFree
pointFulHandler Message Net ()
-pointFulHandler msg = whenPrefix "'unpf" msg $ ap ((≫=) liftIO pointFul) replyTo
+pointFulHandler msg = whenPrefix "'unpf" msg $ (reply msg =≪) liftIO pointFul
sayHandler Message Net ()
sayHandler = flip (whenPrefixAdmin "'say") doSay
- where doSay (Message _ _ ps) = privmsg (target ps) (message ps)
+ where doSay ps = privmsg (target ps) (message ps)
target ps = nthWord 2 $ last ps
message ps = dropFirstWord dropFirstWord $ last ps
quitHandler Message Net ()
quitHandler = flip (whenPrefixAdmin "'quit") doQuit
- where doQuit (Message _ _ ps) = quit (dropFirstWord $ last ps)
- liftIO exitSuccess
+ where doQuit ps = quit (dropFirstWord $ last ps) liftIO exitSuccess
typeHandler Message Net ()
-typeHandler msg = whenPrefix "'type" msg $ ap ((≫=) liftIO typeOf) replyTo
+typeHandler msg = whenPrefix "'type" msg $ (reply msg =≪) liftIO typeOf
View
@@ -21,8 +21,8 @@ hsFile ∷ String
hsFile = "L" -- A bit dumb, relies on the current working directory
-- Call out to the mueval binary
-evalHsExt Message IO ByteString
-evalHsExt (Message _ _ params) = do
+evalHsExt Params IO ByteString
+evalHsExt params = do
(_, out, err) liftIO $ readProcessWithExitCode "mueval" args ""
return $ " " pack out pack err
where expr = dropFirstWord $ last params
@@ -33,8 +33,8 @@ evalHsExt (Message _ _ params) = do
, "-t30" ]
-- Get inferred type of an expression
-typeOf Message IO ByteString
-typeOf (Message _ _ params) = do
+typeOf Params IO ByteString
+typeOf params = do
let expr = dropFirstWord $ last params
t liftIO I.runInterpreter
$ I.loadModules [hsFile]
@@ -50,14 +50,14 @@ niceErrors ∷ [GhcError] → ByteString
niceErrors = excerpt' intercalate " " concatMap (split 10) fmap (pack I.errMsg)
-- Pointfree refactoring
-pointy FilePath Message IO ByteString
-pointy p (Message _ _ params) = do
+pointy FilePath Params IO ByteString
+pointy p params = do
let expr = dropFirstWord $ last params
(_, out, _) liftIO $ readProcessWithExitCode p [unpack expr] ""
return intercalate " " split 10 $ pack out
-pointFree Message IO ByteString
+pointFree Params IO ByteString
pointFree = pointy "pointfree"
-pointFul Message IO ByteString
+pointFul Params IO ByteString
pointFul = pointy "pointful"
View
@@ -17,9 +17,8 @@ import Utils as U
write Message Net ()
write msg = do
h asks socket
- liftIO hPutStrLn h $ encodedMsg
- liftIO putStrLn $ "sent: " encodedMsg
- where encodedMsg = encode msg
+ liftIO hPutStrLn h $ encode msg
+ liftIO putStrLn $ "sent: " encode msg
privmsg Param ByteString Net ()
privmsg c m = write $ Message Nothing "PRIVMSG" [c, U.excerpt' m]
@@ -34,8 +33,8 @@ quit ∷ Param → Net ()
quit = write Message Nothing "QUIT" return
-- Convenience function to reply to the correct channel or person
-replyTo Message ByteString Net ()
-replyTo msg reply = case msg of
- (Message (Just (User nn _ _)) _ (p:_))
- let recp = if p nick then nn else p in privmsg recp reply
- _ return ()
+reply Message ByteString Net ()
+reply msg bs = case msg of
+ (Message (Just (User nn _ _)) _ (p:_))
+ let recp = if p nick then nn else p in privmsg recp bs
+ _ return ()

0 comments on commit 18a3358

Please sign in to comment.