{-# Language BangPatterns #-}

{-|
Module      : Irc.Modes
Description : Operations for interpreting mode changes
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module provides support for interpreting the modes changed by
a MODE command.

-}
module Irc.Modes
  (
  -- * Interpretation of modes
    ModeTypes(..)
  , modesLists
  , modesAlwaysArg
  , modesSetArg
  , modesNeverArg
  , modesPrefixModes
  , defaultModeTypes
  , defaultUmodeTypes

  -- * Operations for working with MODE command parameters
  , splitModes
  , unsplitModes
  ) where

import           Data.Text (Text)
import qualified Data.Text as Text
import           View

-- | Settings that describe how to interpret channel modes
data ModeTypes = ModeTypes
  { ModeTypes -> [Char]
_modesLists       :: [Char] -- ^ modes for channel lists (e.g. ban)
  , ModeTypes -> [Char]
_modesAlwaysArg   :: [Char] -- ^ modes that always have an argument
  , ModeTypes -> [Char]
_modesSetArg      :: [Char] -- ^ modes that have an argument when set
  , ModeTypes -> [Char]
_modesNeverArg    :: [Char] -- ^ modes that never have arguments
  , ModeTypes -> [(Char, Char)]
_modesPrefixModes :: [(Char,Char)] -- ^ modes requiring a nickname argument (mode,sigil)
  }
  deriving Int -> ModeTypes -> ShowS
[ModeTypes] -> ShowS
ModeTypes -> [Char]
(Int -> ModeTypes -> ShowS)
-> (ModeTypes -> [Char])
-> ([ModeTypes] -> ShowS)
-> Show ModeTypes
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ModeTypes] -> ShowS
$cshowList :: [ModeTypes] -> ShowS
show :: ModeTypes -> [Char]
$cshow :: ModeTypes -> [Char]
showsPrec :: Int -> ModeTypes -> ShowS
$cshowsPrec :: Int -> ModeTypes -> ShowS
Show

-- | Lens for '_modesList'
modesLists :: Functor f => ([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesLists :: ([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesLists [Char] -> f [Char]
f ModeTypes
m = (\[Char]
x -> ModeTypes
m { _modesLists :: [Char]
_modesLists = [Char]
x }) ([Char] -> ModeTypes) -> f [Char] -> f ModeTypes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> f [Char]
f (ModeTypes -> [Char]
_modesLists ModeTypes
m)

-- | Lens for '_modesAlwaysArg'
modesAlwaysArg :: Functor f => ([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesAlwaysArg :: ([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesAlwaysArg [Char] -> f [Char]
f ModeTypes
m = (\[Char]
x -> ModeTypes
m { _modesAlwaysArg :: [Char]
_modesAlwaysArg = [Char]
x }) ([Char] -> ModeTypes) -> f [Char] -> f ModeTypes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> f [Char]
f (ModeTypes -> [Char]
_modesAlwaysArg ModeTypes
m)

-- | Lens for '_modesSetArg'
modesSetArg :: Functor f => ([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesSetArg :: ([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesSetArg [Char] -> f [Char]
f ModeTypes
m = (\[Char]
x -> ModeTypes
m { _modesSetArg :: [Char]
_modesSetArg = [Char]
x }) ([Char] -> ModeTypes) -> f [Char] -> f ModeTypes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> f [Char]
f (ModeTypes -> [Char]
_modesSetArg ModeTypes
m)

-- | Lens for '_modesNeverArg'
modesNeverArg :: Functor f => ([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesNeverArg :: ([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesNeverArg [Char] -> f [Char]
f ModeTypes
m = (\[Char]
x -> ModeTypes
m { _modesNeverArg :: [Char]
_modesNeverArg = [Char]
x }) ([Char] -> ModeTypes) -> f [Char] -> f ModeTypes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> f [Char]
f (ModeTypes -> [Char]
_modesNeverArg ModeTypes
m)


-- | Lens for '_modesPrefixModes'
modesPrefixModes :: Functor f => ([(Char,Char)] -> f [(Char,Char)]) -> ModeTypes -> f ModeTypes
modesPrefixModes :: ([(Char, Char)] -> f [(Char, Char)]) -> ModeTypes -> f ModeTypes
modesPrefixModes [(Char, Char)] -> f [(Char, Char)]
f ModeTypes
m = (\[(Char, Char)]
x -> ModeTypes
m { _modesPrefixModes :: [(Char, Char)]
_modesPrefixModes = [(Char, Char)]
x }) ([(Char, Char)] -> ModeTypes) -> f [(Char, Char)] -> f ModeTypes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Char, Char)] -> f [(Char, Char)]
f (ModeTypes -> [(Char, Char)]
_modesPrefixModes ModeTypes
m)

-- | The channel modes used by Freenode
defaultModeTypes :: ModeTypes
defaultModeTypes :: ModeTypes
defaultModeTypes = ModeTypes :: [Char] -> [Char] -> [Char] -> [Char] -> [(Char, Char)] -> ModeTypes
ModeTypes
  { _modesLists :: [Char]
_modesLists     = [Char]
"eIbq"
  , _modesAlwaysArg :: [Char]
_modesAlwaysArg = [Char]
"k"
  , _modesSetArg :: [Char]
_modesSetArg    = [Char]
"flj"
  , _modesNeverArg :: [Char]
_modesNeverArg  = [Char]
"CFLMPQScgimnprstz"
  , _modesPrefixModes :: [(Char, Char)]
_modesPrefixModes = [(Char
'o',Char
'@'),(Char
'v',Char
'+')]
  }

-- | The default UMODE used by Freenode
defaultUmodeTypes :: ModeTypes
defaultUmodeTypes :: ModeTypes
defaultUmodeTypes = ModeTypes :: [Char] -> [Char] -> [Char] -> [Char] -> [(Char, Char)] -> ModeTypes
ModeTypes
  { _modesLists :: [Char]
_modesLists     = [Char]
""
  , _modesAlwaysArg :: [Char]
_modesAlwaysArg = [Char]
""
  , _modesSetArg :: [Char]
_modesSetArg    = [Char]
"s"
  , _modesNeverArg :: [Char]
_modesNeverArg  = [Char]
"DQRZgiow"
  , _modesPrefixModes :: [(Char, Char)]
_modesPrefixModes = []
  }

-- | Split up a mode change command and arguments into individual changes
-- given a configuration.
splitModes ::
  ModeTypes {- ^ mode interpretation -} ->
  Text      {- ^ modes               -} ->
  [Text]    {- ^ arguments           -} ->
  Maybe [(Bool,Char,Text)] {- ^ (set, mode, parameter) -}
splitModes :: ModeTypes -> Text -> [Text] -> Maybe [(Bool, Char, Text)]
splitModes !ModeTypes
icm = Bool -> [Char] -> [Text] -> Maybe [(Bool, Char, Text)]
computeMode Bool
True ([Char] -> [Text] -> Maybe [(Bool, Char, Text)])
-> (Text -> [Char]) -> Text -> [Text] -> Maybe [(Bool, Char, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Text.unpack
  where
  computeMode ::
    Bool   {- current polarity -} ->
    [Char] {- remaining modes -} ->
    [Text] {- remaining arguments -} ->
    Maybe [(Bool,Char,Text)]
  computeMode :: Bool -> [Char] -> [Text] -> Maybe [(Bool, Char, Text)]
computeMode Bool
polarity [Char]
modes [Text]
args =

    case [Char]
modes of
      [] | [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
args -> [(Bool, Char, Text)] -> Maybe [(Bool, Char, Text)]
forall a. a -> Maybe a
Just []
         | Bool
otherwise -> Maybe [(Bool, Char, Text)]
forall a. Maybe a
Nothing

      Char
'+':[Char]
ms -> Bool -> [Char] -> [Text] -> Maybe [(Bool, Char, Text)]
computeMode Bool
True  [Char]
ms [Text]
args
      Char
'-':[Char]
ms -> Bool -> [Char] -> [Text] -> Maybe [(Bool, Char, Text)]
computeMode Bool
False [Char]
ms [Text]
args

      Char
m:[Char]
ms
        |             Char
m Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (([Char] -> Const [Char] [Char])
 -> ModeTypes -> Const [Char] ModeTypes)
-> ModeTypes -> [Char]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view ([Char] -> Const [Char] [Char])
-> ModeTypes -> Const [Char] ModeTypes
forall (f :: * -> *).
Functor f =>
([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesAlwaysArg ModeTypes
icm
       Bool -> Bool -> Bool
|| Bool
polarity Bool -> Bool -> Bool
&& Char
m Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (([Char] -> Const [Char] [Char])
 -> ModeTypes -> Const [Char] ModeTypes)
-> ModeTypes -> [Char]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view ([Char] -> Const [Char] [Char])
-> ModeTypes -> Const [Char] ModeTypes
forall (f :: * -> *).
Functor f =>
([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesSetArg ModeTypes
icm
       Bool -> Bool -> Bool
||             Char
m Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Char, Char) -> Char) -> [(Char, Char)] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map (Char, Char) -> Char
forall a b. (a, b) -> a
fst ((([(Char, Char)] -> Const [(Char, Char)] [(Char, Char)])
 -> ModeTypes -> Const [(Char, Char)] ModeTypes)
-> ModeTypes -> [(Char, Char)]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view ([(Char, Char)] -> Const [(Char, Char)] [(Char, Char)])
-> ModeTypes -> Const [(Char, Char)] ModeTypes
forall (f :: * -> *).
Functor f =>
([(Char, Char)] -> f [(Char, Char)]) -> ModeTypes -> f ModeTypes
modesPrefixModes ModeTypes
icm)
       Bool -> Bool -> Bool
||             Char
m Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (([Char] -> Const [Char] [Char])
 -> ModeTypes -> Const [Char] ModeTypes)
-> ModeTypes -> [Char]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view ([Char] -> Const [Char] [Char])
-> ModeTypes -> Const [Char] ModeTypes
forall (f :: * -> *).
Functor f =>
([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesLists ModeTypes
icm ->
           let (Text
arg,[Text]
args') =
                    case [Text]
args of
                      []   -> (Text
Text.empty,[])
                      Text
x:[Text]
xs -> (Text
x,[Text]
xs)
           in ((Bool
polarity,Char
m,Text
arg)(Bool, Char, Text) -> [(Bool, Char, Text)] -> [(Bool, Char, Text)]
forall a. a -> [a] -> [a]
:) ([(Bool, Char, Text)] -> [(Bool, Char, Text)])
-> Maybe [(Bool, Char, Text)] -> Maybe [(Bool, Char, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> [Char] -> [Text] -> Maybe [(Bool, Char, Text)]
computeMode Bool
polarity [Char]
ms [Text]
args'

        | Bool -> Bool
not Bool
polarity Bool -> Bool -> Bool
&& Char
m Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (([Char] -> Const [Char] [Char])
 -> ModeTypes -> Const [Char] ModeTypes)
-> ModeTypes -> [Char]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view ([Char] -> Const [Char] [Char])
-> ModeTypes -> Const [Char] ModeTypes
forall (f :: * -> *).
Functor f =>
([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesSetArg ModeTypes
icm
       Bool -> Bool -> Bool
||                 Char
m Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (([Char] -> Const [Char] [Char])
 -> ModeTypes -> Const [Char] ModeTypes)
-> ModeTypes -> [Char]
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view ([Char] -> Const [Char] [Char])
-> ModeTypes -> Const [Char] ModeTypes
forall (f :: * -> *).
Functor f =>
([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesNeverArg ModeTypes
icm ->
           do [(Bool, Char, Text)]
res <- Bool -> [Char] -> [Text] -> Maybe [(Bool, Char, Text)]
computeMode Bool
polarity [Char]
ms [Text]
args
              [(Bool, Char, Text)] -> Maybe [(Bool, Char, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool
polarity,Char
m,Text
Text.empty) (Bool, Char, Text) -> [(Bool, Char, Text)] -> [(Bool, Char, Text)]
forall a. a -> [a] -> [a]
: [(Bool, Char, Text)]
res)

        | Bool
otherwise -> Maybe [(Bool, Char, Text)]
forall a. Maybe a
Nothing

-- | Construct the arguments to a MODE command corresponding to the given
-- mode changes.
unsplitModes ::
  [(Bool,Char,Text)] {- ^ (set,mode,parameter) -} ->
  [Text]
unsplitModes :: [(Bool, Char, Text)] -> [Text]
unsplitModes [(Bool, Char, Text)]
modes
  = [Char] -> Text
Text.pack (((Bool, Char, Text) -> (Bool -> [Char]) -> Bool -> [Char])
-> (Bool -> [Char]) -> [(Bool, Char, Text)] -> Bool -> [Char]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool, Char, Text) -> (Bool -> [Char]) -> Bool -> [Char]
forall c. (Bool, Char, c) -> (Bool -> [Char]) -> Bool -> [Char]
combineModeChars ([Char] -> Bool -> [Char]
forall a b. a -> b -> a
const [Char]
"") [(Bool, Char, Text)]
modes Bool
True)
  Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
args
  where
  args :: [Text]
args = [Text
arg | (Bool
_,Char
_,Text
arg) <- [(Bool, Char, Text)]
modes, Bool -> Bool
not (Text -> Bool
Text.null Text
arg)]
  combineModeChars :: (Bool, Char, c) -> (Bool -> [Char]) -> Bool -> [Char]
combineModeChars (Bool
q,Char
m,c
_) Bool -> [Char]
rest Bool
p
    | Bool
p Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
q    =       Char
m Char -> ShowS
forall a. a -> [a] -> [a]
: Bool -> [Char]
rest Bool
p
    | Bool
q         = Char
'+' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
m Char -> ShowS
forall a. a -> [a] -> [a]
: Bool -> [Char]
rest Bool
True
    | Bool
otherwise = Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
m Char -> ShowS
forall a. a -> [a] -> [a]
: Bool -> [Char]
rest Bool
False