diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -3,6 +3,30 @@ +irc-fun-messages 0.2.0.0 -- 2015-10-17 +====================================== + +General, build and documentation changes: + +* Prefix some record field names, they had too generic names + +New APIs, features and enhancements: + +* Recognize action messages (/me) +* Implement parsing of a few more IRC messages, previously unimplemented + +Bug fixes: + +* (None) + +Dependency changes: + +* (None) + + + + + irc-fun-messages 0.1.0.1 -- 2015-09-10 ====================================== diff --git a/irc-fun-messages.cabal b/irc-fun-messages.cabal --- a/irc-fun-messages.cabal +++ b/irc-fun-messages.cabal @@ -1,5 +1,5 @@ name: irc-fun-messages -version: 0.1.0.1 +version: 0.2.0.0 synopsis: Types and functions for working with the IRC protocol. description: Another IRC library. It doesn't provide a client API though. It just provides @@ -9,8 +9,8 @@ The package is based on RFC 2812, with modifications and extensions to work with Freenode. . - NOTE: The handling of IRC protocol messages is FAR from complete, but there - is enough to e.g. create a basic IRC bot. Missing features are being added as + NOTE: The handling of IRC protocol messages is incomplete, but there + is enough to e.g. create an IRC bot. Missing features are being added as needed while working on , and of course patches are welcome. homepage: http://rel4tion.org/projects/irc-fun-messages/ @@ -43,6 +43,7 @@ , Network.IRC.Fun.Messages.Internal.Tokens.Target , Network.IRC.Fun.Messages.Internal.Tokens.Wildcards , Network.IRC.Fun.Messages.Internal.Types + , Network.IRC.Fun.Messages.Internal.Util -- other-extensions: build-depends: base >=4.7 && <5 , regex-applicative >=0.3.1 diff --git a/src/Network/IRC/Fun/Messages/Internal/Parse.hs b/src/Network/IRC/Fun/Messages/Internal/Parse.hs --- a/src/Network/IRC/Fun/Messages/Internal/Parse.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Parse.hs @@ -28,17 +28,18 @@ import Data.Bits (testBit) import Data.Char (toUpper) -import Data.List (isSuffixOf) ---import Data.Maybe (fromMaybe) +import Data.List (isSuffixOf, stripPrefix) import Network.IRC.Fun.Messages.Mask (parseMask) import Network.IRC.Fun.Messages.Modes (parseUserMode) +import Network.IRC.Fun.Messages.Internal.Types +import Network.IRC.Fun.Messages.Internal.Util +import Text.Regex.Applicative +import Text.Regex.Applicative.Common (decimal) + import qualified Network.IRC.Fun.Messages.Internal.Tokens.Message as T import qualified Network.IRC.Fun.Messages.Internal.Tokens.Other as T import qualified Network.IRC.Fun.Messages.Internal.Tokens.Reply as T import qualified Network.IRC.Fun.Messages.Internal.Tokens.Target as T -import Network.IRC.Fun.Messages.Internal.Types -import Text.Regex.Applicative -import Text.Regex.Applicative.Common (decimal) ------------------------------------------------------------------------------- -- Parsing @@ -54,12 +55,12 @@ messageIsReply :: GenericMessage -> Bool messageIsReply msg = let prefOk = - case prefix msg of + case gmPrefix msg of Nothing -> False Just (Server _) -> True Just (Nick {}) -> False cmdOk = - case command msg of + case gmCommand msg of StringCommand _ -> False NumericCommand _ -> True in prefOk && cmdOk @@ -69,13 +70,13 @@ -- 'Left' an error message. messageToReply :: GenericMessage -> Either String GenericReply messageToReply msg = - case (prefix msg, command msg, parameters msg) of + case (gmPrefix msg, gmCommand msg, gmParams msg) of (Just (Server s), NumericCommand n, p : ps) -> Right GenericReply - { sender = s - , code = n - , target = NickTarget p - , params = ps + { grSender = s + , grCode = n + , grTarget = NickTarget p + , grParams = ps } (Just (Server _), NumericCommand _, []) -> Left "No parameters, must have at least one" @@ -101,183 +102,196 @@ -- Analysis ------------------------------------------------------------------------------- +mapLeft :: (a -> c) -> Either a b -> Either c b +mapLeft f (Left x) = Left $ f x +mapLeft _ (Right y) = Right y + analyzeMessage' :: Maybe Prefix -> String -> [Parameter] -> Either String Message -analyzeMessage' prefix cmd params = +analyzeMessage' _prefix cmd params = mapLeft show $ case map toUpper cmd of -- Connection registration - "PASS" -> - case params of - [pass] -> Right $ PassMessage pass - [] -> Left "Password missing" - _ -> Left "Too many parameters" - "NICK" -> - case params of - [nick] -> Right $ NickMessage nick - [] -> Left "Nickname missing" - _ -> Left "Too many parameters" - "USER" -> - case params of - [user, mode, _, realname] -> - case match decimal mode :: Maybe Int of - (Just m) -> Right $ UserMessage user - (testBit m 3) - (testBit m 2) - realname - Nothing -> Left " should be a number" - [_:_:_:_:_:_] -> Left "Too many parameters" - _ -> Left "Too few parameters" - "OPER" -> - case params of - [name, pass] -> Right $ OperMessage name pass - [_:_:_:_] -> Left "Too many parameters" - _ -> Left "Too few parameters" - "MODE" -> - case params of - (first:rest) -> - case (match T.nickname first, match T.channel first) of - (Just nick, _) -> - case rest of - [mode] -> - case parseUserMode mode of - Just (remove, add) -> - Right $ UserModeMessage nick - remove - add - Nothing -> - Left "Invalid user mode string" - [] -> Left "Too few parameters" - _ -> Left "Too many parameters" - (Nothing, Just chan) -> Left "Not implemented yet" - {-case parseChannelModeParams rest of - Just X -> - Nothing ->-} - _ -> Left "First parameter invalid" - _ -> - Left "Too new parameters" - "SERVICE" -> - case params of - [nick, _, dist, _, _, info] -> - case parseMask dist of - Just m -> Right $ ServiceMessage nick m info - Nothing -> Left "Distribution mask invalid" - [_:_:_:_:_:_:_:_] -> Left "Too many parameters" - _ -> Left "Too few parameters" - "QUIT" -> - case params of - [] -> Right $ QuitMessage Nothing - [msg] -> Right $ QuitMessage (Just msg) - _ -> Left "Too many parameters" - "SQUIT" -> - case params of - [server, comment] -> Right $ SQuitMessage server comment - [_:_:_:_] -> Left "Too many parameters" - _ -> Left "Too few parameters" + "PASS" -> req1 params $ \ pass -> Right $ PassMessage pass + "NICK" -> req1 params $ \ nick -> Right $ NickMessage nick + "USER" -> req4 params $ \ user mode _ realname -> + case match decimal mode :: Maybe Int of + Just m -> + Right $ + UserMessage user (testBit m 3) (testBit m 2) realname + Nothing -> + Left $ + InvalidArg + (Just 2) + (Just "mode") + (Just "Should be a number") + "OPER" -> req2 params $ \ name pass -> + Right $ OperMessage name pass + "MODE" -> min1 params $ \ first rest -> + case (match T.nickname first, match T.channel first) of + (Just nick, _) -> + case rest of + [mode] -> + case parseUserMode mode of + Just (remove, add) -> + Right $ UserModeMessage nick remove add + Nothing -> + Left $ + InvalidArg (Just 1) (Just "mode") Nothing + l -> Left $ WrongNumArgs (length l) Nothing + (Nothing, Just _chan) -> + Left $ OtherError "Not implemented yet" + {-case parseChannelModeParams rest of + Just X -> + Nothing ->-} + _ -> + Left $ InvalidArg (Just 1) Nothing Nothing + "SERVICE" -> req6 params $ \ nick _ dist _ _ info -> + case parseMask dist of + Just m -> Right $ ServiceMessage nick m info + Nothing -> + Left $ + InvalidArg (Just 3) (Just "distribution mask") Nothing + "QUIT" -> req0m1 params $ \ msg -> Right $ QuitMessage msg + "SQUIT" -> req2 params $ \ server comment -> + Right $ SQuitMessage server comment -- Channel operations - "JOIN" -> - case params of - ["0"] -> Right $ JoinMessage Nothing - [channels] -> - let c = (:) <$> T.channel <*> many (sym ',' *> T.channel) - in case match c channels of - Just cs -> Right $ JoinMessage $ Just (cs, []) - _ -> Left "Invalid parameters" - [channels, keys] -> - let c = (:) <$> T.channel <*> many (sym ',' *> T.channel) - k = (:) <$> T.key <*> many (sym ',' *> T.key) - in case (match c channels, match k keys) of + "JOIN" -> req1m2 params $ \ chans mkeys -> + case (chans, mkeys) of + ("0", Nothing) -> Right $ JoinMessage Nothing + _ -> + let mcs = match (listOf T.channel) chans + mks = maybe (Just []) (match $ listOf T.key) mkeys + in case (mcs, mks) of + (Nothing, _) -> + Left $ + InvalidArg (Just 1) (Just "channels") Nothing + (Just _, Nothing) -> + Left $ + InvalidArg (Just 2) (Just "keys") Nothing (Just cs, Just ks) -> Right $ JoinMessage $ Just (cs, ks) - _ -> - Left "Invalid parameters" - _ -> Left "Invalid parameters" - "PART" -> - case params of - [channels] -> - case match c channels of - Just cs -> Right $ PartMessage cs Nothing - Nothing -> Left "Invalid channel list" - [channels, msg] -> - case match c channels of - Just cs -> Right $ PartMessage cs $ Just msg - Nothing -> Left "Invalid channel list" - _ -> Left "Wrong number of parameters" - where - c = (:) <$> T.channel <*> many (sym ',' *> T.channel) + "PART" -> req1m2 params $ \ chans msg -> + case match (listOf T.channel) chans of + Just cs -> Right $ PartMessage cs msg + Nothing -> Left $ InvalidArg (Just 1) (Just "channels") Nothing -- "MODE" -> Channel mode handled by MODE above - "TOPIC" -> - case params of - [channel] -> Right $ TopicMessage channel Nothing - [channel, topic] -> Right $ TopicMessage channel $ Just topic - [] -> Left "No parameters given" - _ -> Left "Too many parameters" - "NAMES" -> Left "Not implemented yet" - "LIST" -> Left "Not implemented yet" - "INVITE" -> Left "Not implemented yet" - "KICK" -> Left "Not implemented yet" - -- Sending messages - "PRIVMSG" -> + "TOPIC" -> req1m2 params $ \ chan topic -> + Right $ TopicMessage chan topic + "NAMES" -> case params of - [target, text] -> - case match T.msgto target of - Nothing -> Left $ "Invalid message target: " ++ target - Just t -> Right $ PrivMsgMessage t text - (_:_:_:_) -> Left "Too many parameters" - _ -> Left "Too few parameters" - "NOTICE" -> + [] -> Right $ NamesMessage [] Nothing + [chans] -> + case match (listOf T.channel) chans of + Just cs -> Right $ NamesMessage cs Nothing + Nothing -> + Left $ + InvalidArg (Just 1) (Just "channels") Nothing + [chans, target] -> + case match (listOf T.channel) chans of + Just cs -> Right $ NamesMessage cs (Just target) + Nothing -> + Left $ + InvalidArg (Just 1) (Just "channels") Nothing + l -> + Left $ WrongNumArgs (length l) (Just $ Between 0 2) + "LIST" -> case params of - [target, text] -> - case match T.msgto target of - Nothing -> Left $ "Invalid notice target: " ++ target - Just t -> Right $ NoticeMessage t text - (_:_:_:_) -> Left "Too many parameters" - _ -> Left "Too few parameters" + [] -> Right $ ListMessage [] Nothing + [chans] -> + case match (listOf T.channel) chans of + Just cs -> Right $ ListMessage cs Nothing + Nothing -> + Left $ + InvalidArg (Just 1) (Just "channels") Nothing + [chans, target] -> + case match (listOf T.channel) chans of + Just cs -> Right $ ListMessage cs (Just target) + Nothing -> + Left $ + InvalidArg (Just 1) (Just "channels") Nothing + l -> + Left $ WrongNumArgs (length l) (Just $ Between 0 2) + "INVITE" -> req2 params $ \ nick chan -> + case (match T.nickname nick, match T.channel chan) of + (Nothing, _) -> + Left $ InvalidArg (Just 1) (Just "nickname") Nothing + (Just _, Nothing) -> + Left $ InvalidArg (Just 2) (Just "channel") Nothing + (Just n, Just c) -> Right $ InviteMessage n c + "KICK" -> req2m3 params $ \ chans users comment -> + let mcs = match (listOf T.channel) chans + ucs = match (listOf T.nickname) users + in case (mcs, ucs) of + (Nothing, _) -> + Left $ InvalidArg (Just 1) (Just "channels") Nothing + (Just _, Nothing) -> + Left $ InvalidArg (Just 2) (Just "users") Nothing + (Just cs, Just us) -> + let lc = length cs + lu = length us + in if lc == 1 || lc == lu + then Right $ KickMessage cs us comment + else Left $ OtherError "Invalid list lengths" + -- Sending messages + "PRIVMSG" -> req2 params $ \ target text -> + case match T.msgto target of + Nothing -> + Left $ InvalidArg (Just 1) (Just "target") (Just target) + Just t -> + Right $ case stripPrefix "\1ACTION " text of + Just s -> + if not (null s) && last s == '\1' + then PrivActionMessage t $ init s + else PrivMsgMessage t text + Nothing -> PrivMsgMessage t text + "NOTICE" -> req2 params $ \ target text -> + case match T.msgto target of + Nothing -> + Left $ InvalidArg (Just 1) (Just "target") (Just target) + Just t -> + Right $ NoticeMessage t text -- Server queries and commands - "MOTD" -> Left "Not implemented yet" - "LUSERS" -> Left "Not implemented yet" - "VERSION" -> Left "Not implemented yet" - "STATS" -> Left "Not implemented yet" - "LINKS" -> Left "Not implemented yet" - "TIME" -> Left "Not implemented yet" - "CONNECT" -> Left "Not implemented yet" - "TRACE" -> Left "Not implemented yet" - "ADMIN" -> Left "Not implemented yet" - "INFO" -> Left "Not implemented yet" + "MOTD" -> req0m1 params $ \ target -> Right $ MotdMessage target + "LUSERS" -> Left $ OtherError "Not implemented yet" + "VERSION" -> Left $ OtherError "Not implemented yet" + "STATS" -> Left $ OtherError "Not implemented yet" + "LINKS" -> Left $ OtherError "Not implemented yet" + "TIME" -> Left $ OtherError "Not implemented yet" + "CONNECT" -> Left $ OtherError "Not implemented yet" + "TRACE" -> Left $ OtherError "Not implemented yet" + "ADMIN" -> Left $ OtherError "Not implemented yet" + "INFO" -> req0m1 params $ \ target -> + case target of + Nothing -> Right $ InfoMessage Nothing + Just t -> + Right $ case match T.nickname t of + Just n -> InfoMessage (Just $ NickTarget n) + Nothing -> InfoMessage (Just $ ServerTarget t) -- Service query and commands - "SERVLIST" -> Left "Not implemented yet" - "SQUERY" -> Left "Not implemented yet" + "SERVLIST" -> Left $ OtherError "Not implemented yet" + "SQUERY" -> Left $ OtherError "Not implemented yet" -- User based queries - "WHO" -> Left "Not implemented yet" - "WHOIS" -> Left "Not implemented yet" - "WHOWAS" -> Left "Not implemented yet" + "WHO" -> Left $ OtherError "Not implemented yet" + "WHOIS" -> Left $ OtherError "Not implemented yet" + "WHOWAS" -> Left $ OtherError "Not implemented yet" -- Miscellaneous messages - "KILL" -> Left "Not implemented yet" - "PING" -> - case params of - [] -> Left "No parameters given" - [s] -> Right $ PingMessage s Nothing - [s1, s2] -> Right $ PingMessage s1 (Just s2) - _ -> Left "Too many parameters" - "PONG" -> - case params of - [] -> Left "No parameters given" - [s] -> Right $ PongMessage s Nothing - [s1, s2] -> Right $ PongMessage s1 (Just s2) - _ -> Left "Too many parameters" - "ERROR" -> Left "Not implemented yet" + "KILL" -> Left $ OtherError "Not implemented yet" + "PING" -> req1m2 params $ \ s1 s2 -> Right $ PingMessage s1 s2 + "PONG" -> req1m2 params $ \ s1 s2 -> Right $ PongMessage s1 s2 + "ERROR" -> Left $ OtherError "Not implemented yet" -- Optional features - "AWAY" -> Left "Not implemented yet" - "REHASH" -> Left "Not implemented yet" - "DIE" -> Left "Not implemented yet" - "RESTART" -> Left "Not implemented yet" - "SUMMON" -> Left "Not implemented yet" - "USERS" -> Left "Not implemented yet" - "WALLOPS" -> Left "Not implemented yet" - "USERHOST" -> Left "Not implemented yet" - "ISON" -> Left "Not implemented yet" - _ -> Left "Unrecognized command" + "AWAY" -> req0m1 params $ \ text -> Right $ AwayMessage text + "REHASH" -> Left $ OtherError "Not implemented yet" + "DIE" -> Left $ OtherError "Not implemented yet" + "RESTART" -> Left $ OtherError "Not implemented yet" + "SUMMON" -> Left $ OtherError "Not implemented yet" + "USERS" -> Left $ OtherError "Not implemented yet" + "WALLOPS" -> Left $ OtherError "Not implemented yet" + "USERHOST" -> Left $ OtherError "Not implemented yet" + "ISON" -> Left $ OtherError "Not implemented yet" + _ -> Left $ OtherError "Unrecognized command" -- | Read a generic message structure into specific message details. Return -- 'Left' an error description if analysis fails. If the message is detected @@ -287,10 +301,10 @@ analyzeMessage msg = if messageIsReply msg then fmap Left $ messageToReply msg - else case command msg of + else case gmCommand msg of StringCommand c -> - fmap (Right . SpecificMessage (prefix msg)) $ - analyzeMessage' (prefix msg) c (parameters msg) + fmap (Right . SpecificMessage (gmPrefix msg)) $ + analyzeMessage' (gmPrefix msg) c (gmParams msg) _ -> Left "Implementation error" @@ -313,8 +327,8 @@ -- 'Left' an error description if analysis fails. analyzeReply :: GenericReply -> Either String SpecificReply analyzeReply gr = - fmap (SpecificReply (sender gr) (target gr)) $ - analyzeReply' (code gr) (target gr) (params gr) + fmap (SpecificReply (grSender gr) (grTarget gr)) $ + analyzeReply' (grCode gr) (grTarget gr) (grParams gr) -- | Read a generic reply structure into specific message or reply details. -- Return 'Left' an error description if analysis fails. diff --git a/src/Network/IRC/Fun/Messages/Internal/Serialize.hs b/src/Network/IRC/Fun/Messages/Internal/Serialize.hs --- a/src/Network/IRC/Fun/Messages/Internal/Serialize.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Serialize.hs @@ -89,6 +89,8 @@ InviteMessage nn chan -> ("????", error "Not implemented") KickMessage chans users s -> ("????", error "Not implemented") PrivMsgMessage tgt text -> ("PRIVMSG", [showTarget tgt, text]) + PrivActionMessage tgt text -> + ("PRIVMSG", [showTarget tgt, "\1ACTION " ++ text ++ "\1"]) NoticeMessage tgt text -> ("NOTICE", [showTarget tgt, text]) MotdMessage serv -> ("????", error "Not implemented") LusersMessage serv -> ("????", error "Not implemented") @@ -162,13 +164,13 @@ -- generic message value. messageFromReply :: GenericReply -> GenericMessage messageFromReply reply = GenericMessage - { prefix = Just $ Server $ sender reply - , command = NumericCommand $ code reply - , parameters = target' reply : params reply + { gmPrefix = Just $ Server $ grSender reply + , gmCommand = NumericCommand $ grCode reply + , gmParams = target' reply : grParams reply } where - target' (GenericReply { target = NickTarget n }) = n - target' (GenericReply { target = ServerTarget s }) = s + target' (GenericReply { grTarget = NickTarget n }) = n + target' (GenericReply { grTarget = ServerTarget s }) = s ------------------------------------------------------------------------------- -- Serializing @@ -198,9 +200,9 @@ -- | Write a message into an IRC protocol message formatted string. serializeMessage :: GenericMessage -> String serializeMessage msg = concat - [ maybe "" (\ p -> ':' : serializePrefix p ++ " ") $ prefix msg - , serializeCommand $ command msg - , serializeParams $ parameters msg + [ maybe "" (\ p -> ':' : serializePrefix p ++ " ") $ gmPrefix msg + , serializeCommand $ gmCommand msg + , serializeParams $ gmParams msg , "\r\n" ] diff --git a/src/Network/IRC/Fun/Messages/Internal/Types.hs b/src/Network/IRC/Fun/Messages/Internal/Types.hs --- a/src/Network/IRC/Fun/Messages/Internal/Types.hs +++ b/src/Network/IRC/Fun/Messages/Internal/Types.hs @@ -45,6 +45,8 @@ , SpecificMessage (..) , MessageTarget (..) , Message (..) + , AnalysisError (..) + , ArgSpec (..) -- * Modes , UserMode (..) , ChannelMode (..) @@ -179,9 +181,9 @@ -- | A generic IRC message. It consists of a sender prefix, command name -- (string or numeric) and optionally a list of parameters. data GenericMessage = GenericMessage - { prefix :: Maybe Prefix - , command :: Command - , parameters :: [Parameter] + { gmPrefix :: Maybe Prefix + , gmCommand :: Command + , gmParams :: [Parameter] } deriving Show @@ -251,14 +253,15 @@ | ChannelModeMessage [ChannelMode] [ChannelMode] | TopicMessage ChannelName (Maybe ChannelTopic) | NamesMessage [ChannelName] (Maybe ServerName) - | ListMessage [ChannelName] (Maybe (Either ServerName Mask)) + | ListMessage [ChannelName] (Maybe ServerName) | InviteMessage NickName ChannelName | KickMessage [ChannelName] [UserName] (Maybe Comment) -- Sending messages | PrivMsgMessage MessageTarget String + | PrivActionMessage MessageTarget String | NoticeMessage MessageTarget String -- Server queries and commands - | MotdMessage (Maybe (Either ServerName Mask)) + | MotdMessage (Maybe ServerName) | LusersMessage (Maybe (Mask, Maybe ServerName)) | VersionMessage (Maybe (Either ServerName Mask)) | StatsMessage (Maybe (Query, Maybe (Either ServerName Mask))) @@ -688,10 +691,10 @@ -- | TODO data GenericReply = GenericReply - { sender :: ServerName - , code :: Int - , target :: Target - , params :: [Parameter] + { grSender :: ServerName + , grCode :: Int + , grTarget :: Target + , grParams :: [Parameter] } deriving Show @@ -879,3 +882,19 @@ -- data ChannelPrivacy = Secret | Private | Public deriving (Eq, Show) + +-- +data ArgSpec + = Exactly Int + | AtLeast Int + | AtMost Int + | Between Int Int + | OneOf [Int] + deriving (Show) + +-- +data AnalysisError + = WrongNumArgs Int (Maybe ArgSpec) + | InvalidArg (Maybe Int) (Maybe String) (Maybe String) + | OtherError String + deriving (Show) diff --git a/src/Network/IRC/Fun/Messages/Internal/Util.hs b/src/Network/IRC/Fun/Messages/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Messages/Internal/Util.hs @@ -0,0 +1,142 @@ +{- This file is part of irc-fun-messages. + - + - Written in 2015 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Network.IRC.Fun.Messages.Internal.Util + ( listOf + , req0 + , req1 + , req2 + , req3 + , req4 + , req5 + , req6 + , req0m1 + , req1m2 + , req2m3 + , req3m4 + , min1 + ) +where + +import Network.IRC.Fun.Messages.Internal.Types +import Text.Regex.Applicative + +listOf :: Regex a -> Regex [a] +listOf re = (:) <$> re <*> many (sym ',' *> re) + +req0 :: [Parameter] + -> Either AnalysisError Message + -> Either AnalysisError Message +req0 [] f = f +req0 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 0) + +req1 :: [Parameter] + -> (Parameter -> Either AnalysisError Message) + -> Either AnalysisError Message +req1 [p1] f = f p1 +req1 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 1) + +req2 :: [Parameter] + -> (Parameter -> Parameter -> Either AnalysisError Message) + -> Either AnalysisError Message +req2 [p1, p2] f = f p1 p2 +req2 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 2) + +req3 :: [Parameter] + -> (Parameter -> Parameter -> Parameter -> Either AnalysisError Message) + -> Either AnalysisError Message +req3 [p1, p2, p3] f = f p1 p2 p3 +req3 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 3) + +req4 :: [Parameter] + -> ( Parameter + -> Parameter + -> Parameter + -> Parameter + -> Either AnalysisError Message + ) + -> Either AnalysisError Message +req4 [p1, p2, p3, p4] f = f p1 p2 p3 p4 +req4 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 4) + +req5 :: [Parameter] + -> ( Parameter + -> Parameter + -> Parameter + -> Parameter + -> Parameter + -> Either AnalysisError Message + ) + -> Either AnalysisError Message +req5 [p1, p2, p3, p4, p5] f = f p1 p2 p3 p4 p5 +req5 l _ = Left $ WrongNumArgs (length l) (Just $ Exactly 5) + +req6 :: [Parameter] + -> ( Parameter + -> Parameter + -> Parameter + -> Parameter + -> Parameter + -> Parameter + -> Either AnalysisError Message + ) + -> Either AnalysisError Message +req6 [p1, p2, p3, p4, p5,p6] f = f p1 p2 p3 p4 p5 p6 +req6 l _ = Left $ + WrongNumArgs (length l) (Just $ Exactly 6) + +req0m1 :: [Parameter] + -> (Maybe Parameter -> Either AnalysisError Message) + -> Either AnalysisError Message +req0m1 [] f = f Nothing +req0m1 [p1] f = f $ Just p1 +req0m1 l _ = Left $ WrongNumArgs (length l) (Just $ Between 0 1) + +req1m2 :: [Parameter] + -> (Parameter -> Maybe Parameter -> Either AnalysisError Message) + -> Either AnalysisError Message +req1m2 [p1] f = f p1 Nothing +req1m2 [p1, p2] f = f p1 (Just p2) +req1m2 l _ = Left $ WrongNumArgs (length l) (Just $ Between 1 2) + +req2m3 :: [Parameter] + -> ( Parameter + -> Parameter + -> Maybe Parameter + -> Either AnalysisError Message + ) + -> Either AnalysisError Message +req2m3 [p1, p2] f = f p1 p2 Nothing +req2m3 [p1, p2, p3] f = f p1 p2 (Just p3) +req2m3 l _ = Left $ WrongNumArgs (length l) (Just $ Between 2 3) + +req3m4 :: [Parameter] + -> ( Parameter + -> Parameter + -> Parameter + -> Maybe Parameter + -> Either AnalysisError Message + ) + -> Either AnalysisError Message +req3m4 [p1, p2, p3] f = f p1 p2 p3 Nothing +req3m4 [p1, p2, p3, p4] f = f p1 p2 p3 (Just p4) +req3m4 l _ = Left $ + WrongNumArgs (length l) (Just $ Between 3 4) + +min1 :: [Parameter] + -> (Parameter -> [Parameter] -> Either AnalysisError Message) + -> Either AnalysisError Message +min1 [] _ = Left $ WrongNumArgs 0 (Just $ AtLeast 1) +min1 (p1:ps) f = f p1 ps