Generic parsing and printing

diff --git a/GenIRC.dcl b/GenIRC.dcl
new file mode 100644 (file)
index 0000000..896362d
--- /dev/null
+++ b/GenIRC.dcl
@@ -0,0 +1,12 @@
+definition module GenIRC
+
+from IRC import :: IRCCommand, :: CSepList
+from Data.Either import :: Either
+from Data.Maybe import :: Maybe
+from Text.Parsers.Simple.Core import :: Error
+
+generic gIRCParse a :: [String] -> (Either Error a, [String])
+generic gIRCPrint a :: a -> [String]
+
+derive gIRCParse IRCCommand, String, Int, Maybe, (,), [], CSepList
+derive gIRCPrint IRCCommand, String, Int, Maybe, (,), [], CSepList

diff --git a/GenIRC.icl b/GenIRC.icl
new file mode 100644 (file)
index 0000000..4a4d754
--- /dev/null
+++ b/GenIRC.icl
@@ -0,0 +1,67 @@
+implementation module GenIRC
+
+from IRC import :: IRCCommand, :: CSepList(CSepList)
+from Data.Func import $
+from StdFunc import o, const
+
+from Text.Parsers.Simple.Core import :: Error
+
+import StdList
+import StdString
+import StdGeneric
+import Data.Either
+import Data.Maybe
+import Data.Tuple
+import Data.Functor
+from Text import class Text(join,split,indexOf,concat), instance Text String
+
+pOne [] = (Left "Expected an argument", [])
+pOne [a:as] = (Right a, as)
+
+generic gIRCParse a :: [String] -> (Either Error a, [String])
+gIRCParse{|UNIT|} a = (Right UNIT, a)
+gIRCParse{|String|} as = pOne as
+gIRCParse{|Int|} as = appFst (fmap toInt) $ pOne as
+gIRCParse{|EITHER|} lp rp as = case lp as of
+       (Right a, rest) = (Right $ LEFT a, rest)
+       (Left e1, _) = case rp as of
+               (Right a, rest) = (Right $ RIGHT a, rest)
+               (Left e2, _) = (Left $ e1 +++ " and " +++ e2, [])
+gIRCParse{|OBJECT|} p as = appFst (fmap OBJECT) $ p as
+gIRCParse{|CONS of d|} p []
+       = (Left $ concat ["Expected a cmd constructor: ", d.gcd_name], [])
+gIRCParse{|CONS of d|} p [a:as]
+       | a <> d.gcd_name = (Left $ concat [
+               "Wrong constructor. expected: ", d.gcd_name, ", got: ", a], [])
+       = case p as of
+               (Right a, rest) = (Right $ CONS a, rest)
+               (Left e, _) = (Left e, [])
+gIRCParse{|PAIR|} pl pr as = case pl as of
+       (Right a1, rest) = case pr rest of
+               (Right a2, rest) = (Right $ PAIR a1 a2, rest)
+               (Left e, _) = (Left e, [])
+       (Left e, _) = (Left e, [])
+gIRCParse{|[]|} pl as = case pl as of
+               (Right e, rest) = case gIRCParse{|*->*|} pl rest of
+                       (Right es, rest) = (Right [e:es], rest)
+                       (Left e, _) = (Left e, [])
+               (Left e, _) = (Right [], as)
+gIRCParse{|Maybe|} pm as
+       = appFst (either (const $ Right Nothing) $ Right o Just) $ pm as
+gIRCParse{|CSepList|} as = appFst (fmap $ CSepList o split ",") $ pOne as
+
+derive gIRCParse (,), IRCCommand
+derive gIRCPrint (,), IRCCommand
+
+generic gIRCPrint a :: a -> [String]
+gIRCPrint{|UNIT|} _ = []
+gIRCPrint{|String|} s = if (indexOf " " s == -1) [s] [":"+++s]
+gIRCPrint{|Int|} i = [toString i]
+gIRCPrint{|EITHER|} lp rp (LEFT i) = lp i
+gIRCPrint{|EITHER|} lp rp (RIGHT i) = rp i
+gIRCPrint{|OBJECT|} lp (OBJECT p) = lp p
+gIRCPrint{|PAIR|} lp rp (PAIR l r) = lp l ++ rp r
+gIRCPrint{|CONS of d|} pc (CONS c) = [d.gcd_name:pc c]
+gIRCPrint{|[]|} pl x = flatten $ map pl x
+gIRCPrint{|Maybe|} pl m = gIRCPrint{|*->*|} pl $ maybeToList m
+gIRCPrint{|CSepList|} (CSepList as) = [join "," as]

diff --git a/IRC.dcl b/IRC.dcl
index d910183..cc3e4b2 100644 (file)
--- a/IRC.dcl
+++ b/IRC.dcl
@@ -1,25 +1,24 @@
 definition module IRC
 
-import IRCBot
 from Data.Maybe import :: Maybe
 from Data.Either import :: Either
 from StdOverloaded import class fromInt, class toInt, class toString, class fromString
 from Text.Parsers.Simple.Core import :: Error
 
 :: IRCMessage =
-       { irc_prefix :: Maybe (Either IRCUser String)
-       , irc_command :: Either IRCNumReply IRCCommand}
+       { irc_prefix    :: Maybe (Either IRCUser String)
+       , irc_command   :: Either IRCNumReply IRCCommand}
 
 :: IRCNumReply =
-       { irc_reply :: IRCReplies
+       { irc_reply     :: IRCReplies
        , irc_recipient :: String
-       , irc_message :: String
+       , irc_message   :: String
        }
 
 :: IRCUser = 
-       { irc_nick :: String
-       , irc_user :: Maybe String
-       , irc_host :: Maybe String
+       { irc_nick      :: String
+       , irc_user      :: Maybe String
+       , irc_host      :: Maybe String
        }
 
 parseIRCMessage :: String -> Either [Error] IRCMessage
@@ -28,6 +27,7 @@ instance toString IRCCommand, IRCReplies, IRCErrors, IRCMessage, IRCUser, IRCNum
 instance fromInt IRCReplies, IRCErrors
 instance toInt IRCReplies, IRCErrors
 
+:: CSepList = CSepList [String]
 :: IRCCommand
        = ADMIN (Maybe String)
        | AWAY String
@@ -37,24 +37,24 @@ instance toInt IRCReplies, IRCErrors
        | INFO (Maybe String)
        | INVITE String String
        | ISON [String]
-       | JOIN [(String, Maybe String)]
+       | JOIN CSepList (Maybe String)
        | KICK String String (Maybe String)
        | KILL String String
        | LINKS (Maybe (Maybe String, String))
-       | LIST (Maybe ([String], Maybe String))
+       | LIST (Maybe (CSepList, Maybe String))
        | LUSERS (Maybe (String, Maybe String))
        | MODE String String (Maybe String) (Maybe String) (Maybe String)
        | MOTD (Maybe String)
-       | NAMES [String]
+       | NAMES CSepList
        | NICK String (Maybe String)
        | NJOIN 
        | NOTICE String String
        | OPER String String 
-       | PART [String]
+       | PART CSepList
        | PASS String
        | PING String (Maybe String)
        | PONG String (Maybe String)
-       | PRIVMSG [String] String
+       | PRIVMSG CSepList String
        | QUIT (Maybe String)
        | REHASH 
        | RESTART 
@@ -70,13 +70,13 @@ instance toInt IRCReplies, IRCErrors
        | TOPIC String (Maybe String)
        | TRACE (Maybe String)
        | USER String String String
-       | USERHOST [String]
+       | USERHOST CSepList
        | USERS (Maybe String)
        | VERSION (Maybe String)
        | WALLOPS String
        | WHO (Maybe String)
-       | WHOIS (Maybe String) [String]
-       | WHOWAS (Maybe String) [String]
+       | WHOIS (Maybe String) String
+       | WHOWAS String (Maybe (String, Maybe String))
 
 :: IRCReplies = RPL_WELCOME | RPL_YOURHOST | RPL_CREATED | RPL_MYINFO |
        RPL_BOUNCE | RPL_TRACELINK | RPL_TRACECONNECTING | RPL_TRACEHANDSHAKE |
@@ -109,9 +109,10 @@ instance toInt IRCReplies, IRCErrors
        ERR_NOTONCHANNEL | ERR_USERONCHANNEL | ERR_NOLOGIN | ERR_SUMMONDISABLED |
        ERR_USERSDISABLED | ERR_NOTREGISTERED | ERR_NEEDMOREPARAMS |
        ERR_ALREADYREGISTRED | ERR_NOPERMFORHOST | ERR_PASSWDMISMATCH |
-       ERR_YOUREBANNEDCREEP | ERR_YOUWILLBEBANNED | ERR_KEYSET | ERR_CHANNELISFULL |
-       ERR_UNKNOWNMODE | ERR_INVITEONLYCHAN | ERR_BANNEDFROMCHAN |
-       ERR_BADCHANNELKEY | ERR_BADCHANMASK | ERR_NOCHANMODES | ERR_BANLISTFULL |
-       ERR_NOPRIVILEGES | ERR_CHANOPRIVSNEEDED | ERR_CANTKILLSERVER |
-       ERR_RESTRICTED | ERR_UNIQOPPRIVSNEEDED | ERR_NOOPERHOST |
-       ERR_UMODEUNKNOWNFLAG | ERR_USERSDONTMATCH
+       ERR_YOUREBANNEDCREEP | ERR_YOUWILLBEBANNED | ERR_KEYSET |
+       ERR_CHANNELISFULL | ERR_UNKNOWNMODE | ERR_INVITEONLYCHAN |
+       ERR_BANNEDFROMCHAN | ERR_BADCHANNELKEY | ERR_BADCHANMASK |
+       ERR_NOCHANMODES | ERR_BANLISTFULL | ERR_NOPRIVILEGES |
+       ERR_CHANOPRIVSNEEDED | ERR_CANTKILLSERVER | ERR_RESTRICTED |
+       ERR_UNIQOPPRIVSNEEDED | ERR_NOOPERHOST | ERR_UMODEUNKNOWNFLAG |
+       ERR_USERSDONTMATCH

diff --git a/IRC.icl b/IRC.icl
index 54bf2db..48542ff 100644 (file)
--- a/IRC.icl
+++ b/IRC.icl
@@ -1,167 +1,135 @@
 implementation module IRC
 
 import StdList, StdTuple, StdOverloaded, StdFunc, StdString, StdChar, StdBool
-import GenPrint
-import Data.Maybe
-import Data.Either
 import _SystemArray
 
-import Text.Parsers.Simple.Core
-import Text.Parsers.Simple.Chars
-import Data.Tuple
-import Control.Monad
+import GenPrint
+import GenIRC
+
 import Control.Applicative
+import Control.Monad
+import Data.Either
+import Data.Maybe
+import Data.Tuple
+import Text.Parsers.Simple.Chars
+import Text.Parsers.Simple.Core
 
 from Data.Functor import <$>
 from Data.Func import $
-from Text import class Text(trim,rtrim,split,indexOf,concat), instance Text String
-import qualified Text
 from StdMisc import undef
+from Text
+       import class Text(trim,rtrim,split,indexOf,concat), instance Text String
+import qualified Text
 
 jon :== 'Text'.join
 
-derive gPrint IRCCommand, IRCReplies, IRCErrors, (,), Maybe, (), Either, IRCMessage, IRCUser, IRCNumReply
+derive gPrint IRCErrors, IRCReplies
 
-Start = jon "\n" $ map printToString
-       [ parseIRCMessage ":clooglebot!~cloogle@dhcp-077-249-221-037.chello.nl QUIT\r\n"
-       , parseIRCMessage ":clooglebot!~cloogle QUIT\r\n"
-       , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 QUIT\r\n"
-       , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY test\r\n"
-       , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY :test with spaces\r\n"
-       , parseIRCMessage ":cherryh.freenode.net NOTICE * :*** Found your hostname\r\n"
-       , parseIRCMessage ":cherryh.freenode.net QUIT :hoi hoi\r\n"
-       , parseIRCMessage ":cherryh.freenode.net ISON a b c d e f :g h\r\n"
-       ]
-
-(<+) infixr 5 :: a b -> String | toString a & toString b
-(<+) a b = toString a +++ toString b
+Start = (map (fmap toString) msgs, msgs)
+where
+       msgs =
+               [ parseIRCMessage ":clooglebot!~cloogle@dhcp-077-249-221-037.chello.nl QUIT\r\n"
+               , parseIRCMessage ":clooglebot!~cloogle QUIT\r\n"
+               , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 QUIT\r\n"
+               , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY test\r\n"
+               , parseIRCMessage ":frobnicator!~frobnicat@92.110.128.124 AWAY :test with spaces\r\n"
+               , parseIRCMessage ":cherryh.freenode.net NOTICE * :*** Found your hostname\r\n"
+               , parseIRCMessage ":cherryh.freenode.net QUIT :hoi hoi\r\n"
+               , parseIRCMessage ":cherryh.freenode.net JOIN #cha,#ch-b #twilight\r\n"
+               , parseIRCMessage ":cherryh.freenode.net ISON a b c d e f :g h\r\n"
+               ]
 
 parseIRCMessage :: String -> Either [Error] IRCMessage
 parseIRCMessage s = case runParser parsePrefix (fromString s) of
-       ([(prefix, rest):_], _)
-               = case parse parseReply rest of
-                       Left e = case parseCmd rest of
-                               Left e2 = Left $ e2 ++ e
-                               Right cmd = Right {IRCMessage | irc_prefix=prefix, irc_command=Right cmd}
-                       Right repl = Right {IRCMessage | irc_prefix=prefix, irc_command=Left repl}
+       ([(prefix, rest):_], _) = case parse parseReply rest of
+               Left e = case parseCmd rest of
+                       Left e2 = Left [e2:e]
+                       Right cmd
+                               = Right {IRCMessage | irc_prefix=prefix, irc_command=Right cmd}
+               Right repl
+                       = Right {IRCMessage | irc_prefix=prefix, irc_command=Left repl}
        (_, es) = Left ["couldn't parse prefix":es]
 
+//Prefix
 parsePrefix :: Parser Char (Maybe (Either IRCUser String))
-parsePrefix = optional (pToken ':' >>| parseEither parseUser parseHost) <* pToken ' '
-
-pOne [] = (Left ["Expected an argument"], [])
-pOne [a:as] = (Right a, as)
+parsePrefix
+       = optional (pToken ':' >>| parseEither parseUser parseHost) <* pToken ' '
+where
+       parseEither :: (Parser a b) (Parser a c) -> Parser a (Either b c)
+       parseEither p q = Left <$> p <|> Right <$> q
 
-generic gIRCParse a :: [String] -> (Either [Error] a, [String])
-gIRCParse{|UNIT|} a = (Right UNIT, a)
-gIRCParse{|String|} as = pOne as
-gIRCParse{|Int|} as = appFst (fmap toInt) $ pOne as
-gIRCParse{|EITHER|} lp rp as = case lp as of
-       (Right a, rest) = (Right $ LEFT a, rest)
-       (Left e1, _) = case rp as of
-               (Right a, rest) = (Right $ RIGHT a, rest)
-               (Left e2, _) = (Left $ e1 ++ e2, [])
-gIRCParse{|OBJECT|} p as = appFst (fmap OBJECT) $ p as
-gIRCParse{|CONS of d|} p [] = (Left ["Expected a cmd constructor: " +++ d.gcd_name], [])
-gIRCParse{|CONS of d|} p [a:as]
-| a <> d.gcd_name = (Left ["Wrong constructor. expected: " +++ d.gcd_name +++ ", got: " +++ a], [])
-= case p as of
-       (Right a, rest) = (Right $ CONS a, rest)
-       (Left e, _) = (Left e, [])
-gIRCParse{|PAIR|} pl pr as = case pl as of
-       (Right a1, rest) = case pr rest of
-               (Right a2, rest) = (Right $ PAIR a1 a2, rest)
-               (Left e, _) = (Left e, [])
-       (Left e, _) = (Left e, [])
-gIRCParse{|[]|} pl as = case pl as of
-               (Right e, rest) = case gIRCParse{|*->*|} pl rest of
-                       (Right es, rest) = (Right [e:es], rest)
-                       (Left e, _) = (Left e, [])
-               (Left e, _) = (Right [], as)
-gIRCParse{|Maybe|} pm as
-       = appFst (either (const $ Right Nothing) $ Right o Just) $ pm as
+       parseUser :: Parser Char IRCUser
+       parseUser = parseNick
+                       >>= \nick->optional (pToken '!' >>| parseUsr)
+                       >>= \muser->optional (pToken '@' >>| parseHost)
+                       >>= \mhost->pure {IRCUser
+                               | irc_nick=nick, irc_user=muser, irc_host=mhost}
+       
+       parseUsr :: Parser Char String
+       parseUsr = toString <$> pSome (pNoneOf [' ', '@':illegal])
+       
+       parseNick :: Parser Char String
+       parseNick = pAlpha 
+               >>= \c ->pMany (pAlpha <|> pDigit <|> pOneOf (fromString "-[]\\`^{}"))
+               >>= \cs->pure (toString [c:cs])
 
-derive gIRCParse (,), (,,), IRCCommand
+       parseHost :: Parser Char String
+       parseHost = jon "." <$> pSepBy parseName (pToken '.')
+               where
+                       parseName :: Parser Char String
+                       parseName = toString <$> pSome (pAlpha <|> pDigit <|> pOneOf ['-'])
 
-parseCmd :: [Char] -> Either [Error] IRCCommand
+//Parse Cmd
+parseCmd :: [Char] -> Either Error IRCCommand
 parseCmd cs = fst $ gIRCParse{|*|} $ argfun $ split " " $ toString cs
        where
                argfun :: [String] -> [String]
                argfun [] = []
                argfun [x:xs]
                # x = trim x
-               | x.[0] == ':' = [jon " " $ [x:map rtrim xs]]
+               | x.[0] == ':' = [jon " " $ [x % (1, size x):map rtrim xs]]
                | otherwise = [x:argfun xs]
 
+//Reply
 parseReply :: Parser Char IRCNumReply
 parseReply = (toString <$> pSome pDigit)
        >>= \rep->pMiddle
        >>= \recipient->spaceParser >>| (toString <$> pSome (pNoneOf illegal))
-       >>= \msg->pure {IRCNumReply|irc_reply=fs rep,irc_recipient=recipient,irc_message=msg}
+       >>= \msg->pure {IRCNumReply
+               | irc_reply=fromInt $ toInt rep
+               , irc_recipient=recipient,irc_message=msg}
        where
-               fs :: String -> IRCReplies
-               fs s = fromInt $ toInt s
-//
-spaceParser :: Parser Char [Char]
-spaceParser = pMany $ pToken ' '
-//
-//parseServer :: Parser Char String
-//parseServer = pFail
-//
-parseEither :: (Parser a b) (Parser a c) -> Parser a (Either b c)
-parseEither p q = Left <$> p <|> Right <$> q
+               pMiddle :: Parser Char String
+               pMiddle = fmap toString $ spaceParser >>| liftM2 (\x xs->[x:xs])
+                       (pSatisfy (not o ((==)':'))) (pMany $ pNoneOf [' ':illegal])
 
-parseUser :: Parser Char IRCUser
-parseUser = parseNick
-               >>= \nick->optional (pToken '!' >>| parseUsr)
-               >>= \muser->optional (pToken '@' >>| parseHost)
-               >>= \mhost->pure {IRCUser | irc_nick=nick, irc_user=muser, irc_host=mhost}
+               spaceParser :: Parser Char [Char]
+               spaceParser = pMany $ pToken ' '
 
-parseUsr :: Parser Char String
-parseUsr = toString <$> pSome (pNoneOf [' ', '@':illegal])
-
-parseNick :: Parser Char String
-parseNick = pAlpha >>= \c->pMany (pAlpha <|> pDigit <|> pSpecial)
-       >>= \cs->pure (toString [c:cs])
-
-pSpecial :: Parser Char Char
-pSpecial = pOneOf ['-', '[', ']', '\\', '\`', '^', '{', '}']
+//Common parsers
+pNoneOf :: [a] -> Parser a a | Eq a
+pNoneOf l = pSatisfy (not o flip isMember l)
 
-parseHost :: Parser Char String
-parseHost = jon "." <$> pSepBy parseName (pToken '.')
-       where
-               parseName :: Parser Char String
-               parseName = toString <$> pSome (pAlpha <|> pDigit <|> pOneOf ['-'])
+illegal :: [Char]
+illegal = ['\x00','\r','\n']
 
 instance toString IRCNumReply where
-       toString m = toInt m.irc_reply <+ " " <+ m.irc_recipient <+ " " <+ formatMSG m.irc_message
+       toString m = toInt m.irc_reply <+ " " <+
+               m.irc_recipient <+ concat (gIRCPrint{|*|} m.irc_message)
 instance toString IRCMessage where
        toString m = maybe "" (\s->either ((<+) ":") id s <+ " ") m.irc_prefix
                <+ either toString toString m.irc_command
-
 instance toString IRCUser where
        toString m = m.irc_nick <+ maybe "" ((<+) "!") m.irc_user
                <+ maybe "" ((<+) "@") m.irc_host
-
-pMiddle :: Parser Char String
-pMiddle = fmap toString $
-       spaceParser >>| liftM2 (\x xs->[x:xs]) (pSatisfy (not o ((==)':')) (pMany $ pNoneOf [' ':illegal]))
-
-pNoneOf :: [a] -> Parser a a | Eq a
-pNoneOf l = pSatisfy (not o flip isMember l)
-
-illegal :: [Char]
-illegal = ['\x00','\r','\n']
-
 instance toString IRCCommand where
-       toString r = jon " " (gIRCPrint{|*|} r) +++ "\r\n"
-
-formatMSG :: String -> String
-formatMSG s = if (indexOf " " s > 0 || indexOf " " s > 0) (":" +++ s) s
-
+       toString m = jon " " (gIRCPrint{|*|} m) +++ "\r\n"
 instance toString IRCReplies where toString r = printToString r
 instance toString IRCErrors where toString r = printToString r
 
+(<+) infixr 5 :: a b -> String | toString a & toString b
+(<+) a b = toString a +++ toString b
+
 instance fromInt IRCReplies where
        fromInt r = case r of 
                1 = RPL_WELCOME; 2 = RPL_YOURHOST;

diff --git a/test.icl b/test.icl
index 5ffe818..d67e97d 100644 (file)
--- a/test.icl
+++ b/test.icl
@@ -10,7 +10,7 @@ Start :: [String]
 Start = map toString
        [NICK "clooglebot" Nothing
        ,USER "cloogle" "0" "Cloogle bot"
-       ,JOIN [("#cloogle", Nothing)]
-       ,PRIVMSG ["#cloogle"] "Hello world"
+       ,JOIN (CSepList ["#cloogle"]) Nothing
+       ,PRIVMSG (CSepList ["#cloogle"]) "Hello world"
        ,QUIT Nothing
        ]