Commit 7a2a0cc9 authored by Mart Lubbers's avatar Mart Lubbers

Generic parsing and printing

parent e6122274
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
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]
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
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;
......
......@@ -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
]
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment