From f828f3a79cfcfb21c6c7a7773905cc210a739f75 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Wed, 8 Mar 2017 15:08:49 +0100 Subject: [PATCH] started with parsing --- IRC.dcl | 21 ++++++++--- IRC.icl | 104 ++++++++++++++++++++++++++++++++++++++++++++++++---- Makefile | 2 +- cloogle.icl | 14 +++++-- 4 files changed, 123 insertions(+), 18 deletions(-) diff --git a/IRC.dcl b/IRC.dcl index d88205b..afb7a74 100644 --- a/IRC.dcl +++ b/IRC.dcl @@ -1,7 +1,22 @@ definition module IRC from Data.Maybe import :: Maybe -from StdOverloaded import class fromInt, class toInt, class toString +from Data.Either import :: Either +from StdOverloaded import class fromInt, class toInt, class toString, class fromString + +:: IRCMessage = + { irc_prefix :: Maybe (Either String IRCUser) + , irc_command :: IRCCommands} + +:: IRCUser = + { irc_nick :: String + , irc_user :: Maybe String + , irc_host :: Maybe String + } + +instance toString IRCCommands, IRCReplies, IRCErrors, IRCMessage, IRCUser +instance fromInt IRCReplies, IRCErrors +instance toInt IRCReplies, IRCErrors :: IRCCommands = ADMIN (Maybe String) @@ -90,7 +105,3 @@ from StdOverloaded import class fromInt, class toInt, class toString ERR_NOPRIVILEGES | ERR_CHANOPRIVSNEEDED | ERR_CANTKILLSERVER | ERR_RESTRICTED | ERR_UNIQOPPRIVSNEEDED | ERR_NOOPERHOST | ERR_UMODEUNKNOWNFLAG | ERR_USERSDONTMATCH - -instance toString IRCCommands, IRCReplies, IRCErrors -instance fromInt IRCReplies, IRCErrors -instance toInt IRCReplies, IRCErrors diff --git a/IRC.icl b/IRC.icl index 098c759..5601e9a 100644 --- a/IRC.icl +++ b/IRC.icl @@ -7,11 +7,99 @@ import Data.Maybe import Data.Either import StdFunc import StdString -from Text import class Text(..), instance Text String +import StdChar + +import Text.Parsers.Simple.Core +import Text.Parsers.Simple.Chars +import Control.Monad +import Control.Applicative +from Data.Functor import <$> + +from Data.Func import $ +from Text import class Text(concat), instance Text String +import qualified Text from StdMisc import undef +jon :== 'Text'.join + derive gPrint IRCCommands, IRCReplies, IRCErrors, (,), Maybe, (), Either +:: IRCMessage = + { irc_prefix :: Maybe (Either String IRCUser) + , irc_command :: IRCCommands + } + +:: IRCUser = + { irc_nick :: String + , irc_user :: Maybe String + , irc_host :: Maybe String + } + +//Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 PRIVMSG #cloogle :!query ^_^\r\n" +Start = runParser parseMessage $ fromString ":frobnicator!~frobnicat@92.110.128.124 QUIT\r\n" + +(<+) infixr 5 :: a b -> String | toString a & toString b +(<+) a b = toString a +++ toString b + +parseIRCMessage :: (String -> Either [Error] IRCMessage) +parseIRCMessage = parse parseMessage o fromString + +parseMessage :: Parser Char IRCMessage +parseMessage = optional (parseEither parseHost parseUser) <* spaceParser + >>= \mprefix->parseCommand + <* pToken '\r' <* pToken '\n' + >>= \cmd->pure {IRCMessage | irc_prefix=mprefix, irc_command=cmd} + +pCommand :: String -> Parser Char [Char] +pCommand s = pList (map pToken $ fromString s) <* spaceParser + +parseCommand :: Parser Char IRCCommands +parseCommand = pFail//pCommand "QUIT" >>| QUIT <$> optional (pure "") + + +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 + +parseUser :: Parser Char IRCUser +parseUser = pToken ':' >>| 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 (pSatisfy (not o flip isMember [' ', '\x00', '\x0d', '\x0a', '@'])) + +parseNick :: Parser Char String +parseNick = pAlpha >>= \c->pMany (pAlpha <|> pDigit <|> pSpecial) + >>= \cs->pure (toString [c:cs]) + +pSpecial :: Parser Char Char +pSpecial = pOneOf ['-', '[', ']', '\\', '\`', '^', '{', '}'] + +parseHost :: Parser Char String +parseHost = parseName + >>= \nm->pMany (pToken '.' >>| parseName) + >>= \nms->pure (concat [nm:nms]) + where + parseName :: Parser Char String + parseName = toString <$> pSome (pAlpha <|> pDigit <|> pToken '.') + +IRCCommandParser :: Parser Char IRCCommands +IRCCommandParser = pFail + +instance toString IRCMessage where + toString m = maybe "" (\s->either id ((<+) ":") s <+ " ") m.irc_prefix <+ m.irc_command + +instance toString IRCUser where + toString m = m.irc_nick <+ maybe "" ((<+) "!") m.irc_user + <+ maybe "" ((<+) "@") m.irc_host + instance toString IRCCommands where toString r = flip (+++) "\r\n" case r of //ADMIN (Maybe String) @@ -23,7 +111,7 @@ instance toString IRCCommands where //INVITE String String //ISON [String] JOIN chs = "JOIN " +++ (if (isEmpty chs) "0" - (join ", " [join " " [ch:maybeToList mk]\\(ch, mk)<-chs])) + (jon ", " [jon " " [ch:maybeToList mk]\\(ch, mk)<-chs])) //KICK String String (Maybe String) //KILL String String //LINKS (Maybe (Maybe String, String)) @@ -32,16 +120,16 @@ instance toString IRCCommands where //MODE String //MOTD (Maybe String) //NAMES [String] - NICK n = join " " ["NICK", n] + NICK n = jon " " ["NICK", n] //NJOIN //NOTICE String String //OPER String String //PART [String] //PASS String - PING a mb = join " " ["PING",a:maybeToList mb] - PONG a mb = join " " ["PONG",a:maybeToList mb] - PRIVMSG dest msg = join " " ["PRIVMSG", dest, ":"+++msg] - QUIT msg = join " " ["QUIT":maybeToList msg] + PING a mb = jon " " ["PING",a:maybeToList mb] + PONG a mb = jon " " ["PONG",a:maybeToList mb] + PRIVMSG dest msg = jon " " ["PRIVMSG", dest, ":"+++msg] + QUIT msg = jon " " ["QUIT":maybeToList msg] //REHASH //RESTART //SERVER @@ -55,7 +143,7 @@ instance toString IRCCommands where //TIME (Maybe String) //TOPIC String (Maybe String) //TRACE (Maybe String) - USER login mode rn = join " " ["USER", login, toString mode, "*", ":"+++rn] + USER login mode rn = jon " " ["USER", login, toString mode, "*", ":"+++rn] //USERHOST [String] //USERS (Maybe String) //VERSION (Maybe String) diff --git a/Makefile b/Makefile index ca5595b..70420e8 100644 --- a/Makefile +++ b/Makefile @@ -15,7 +15,7 @@ CLMLIBS:=\ -I $(CLEAN_HOME)/lib/Dynamics\ -I ./cloogle-sub/backend -BINARIES:=test cloogle +BINARIES:=test cloogle IRC all: $(BINARIES) diff --git a/cloogle.icl b/cloogle.icl index fa3bb50..29cee80 100644 --- a/cloogle.icl +++ b/cloogle.icl @@ -142,14 +142,14 @@ cloogle data w processResult :: Result -> String processResult (FunctionResult (br, {func})) - = "Function in " +++ br.library +++ ": " +++ br.modul +++ " - " +++ func + = "Function in " +++ br.library +++ ": " +++ br.modul +++ "\n" +++ func processResult (TypeResult (br, {type})) - = "Type in " +++ br.library +++ ": " +++ br.modul +++ " - " +++ limitResults type + = "Type in " +++ br.library +++ ": " +++ br.modul +++ "\n" +++ limitResults type processResult (ClassResult (br, {class_name,class_funs})) - = "Class in " +++ br.library +++ ": " +++ br.modul +++ " - " +++ class_name +++ " with " + = "Class in " +++ br.library +++ ": " +++ br.modul +++ "\n" +++ class_name +++ " with " +++ toString (length class_funs) +++ " class functions" processResult (MacroResult (br, {macro_name})) - = "Macro in " +++ br.library +++ ": " +++ br.modul +++ " - " +++ macro_name + = "Macro in " +++ br.library +++ ": " +++ br.modul +++ "\n" +++ macro_name processResult (ModuleResult (br, _)) = "Module in " +++ br.library +++ ": " +++ br.modul @@ -167,9 +167,15 @@ cloogle data w send :: [String] TCP_DuplexChannel *World -> (TCP_DuplexChannel, *World) send [] chan w = (chan, w) send [msg:msgs] {sChannel,rChannel} w +# (_, w) = sleep 250000 w # (rpt,i,sChannel,w) = send_MT TIMEOUT (toByteSeq msg) sChannel w | rpt <> TR_Success = abort "Could not send request\n" = send msgs {sChannel=sChannel,rChannel=rChannel} w + where + sleep :: !Int !*World -> (!Int, *World) + sleep i w = code { + ccall usleep "I:I:A" + } recv :: TCP_DuplexChannel *World -> (Maybe String, TCP_DuplexChannel, *World) recv {sChannel,rChannel} w -- 2.20.1