From: Mart Lubbers Date: Wed, 12 Jul 2017 07:09:16 +0000 (+0200) Subject: Generic parsing and printing X-Git-Url: https://git.martlubbers.net/?p=cloogle-irc.git;a=commitdiff_plain;h=7a2a0cc9ba44d6073ae1778b07738c8d425e9cb5 Generic parsing and printing --- diff --git a/GenIRC.dcl b/GenIRC.dcl new file mode 100644 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 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 --- 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 --- 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 --- 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 ]