{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
module Network.Yak.Types
(
Prefix(..),
Host(..),
hostNick,
hostUser,
hostHost,
Msg(..),
build,
buildPrefix,
vacant,
(<:>),
castMsg,
SomeMsg(..),
Unused(..),
Flag(..),
SList(..),
CList(..),
Parameter(..),
PList(..),
phead,
ptail,
params,
prefix,
Channel(..),
Message(..),
Nickname,
Username,
Hostname,
Mask,
Modes(..),
Token(..),
UReply(..),
ureplyNick,
ureplyIsOp,
ureplyIsAway,
ureplyHostname,
Member(..),
memberPrefix,
memberData
)
where
import Control.Applicative
import Control.Lens
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty(..))
import Data.ByteString.Char8 (ByteString)
import Data.Attoparsec.ByteString.Char8
import Data.Text (Text)
import Data.Void
import Data.Maybe (fromMaybe)
import Data.Word (Word)
import Data.Proxy
import Data.Time.Clock.POSIX
import Data.Kind (Type)
import Data.Text.Encoding
import Data.String
import GHC.TypeLits
import GHC.Generics
import GHC.Exts (IsList (..))
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as B
type Username = Text
type Nickname = Text
type Mask = Text
type Hostname = Text
declareLenses [d|
data Host = Host
{ hostNick :: Nickname
, hostUser :: Maybe Username
, hostHost :: Maybe Hostname
}
deriving (Eq, Show, Read, Ord, Generic)
|]
data Prefix
= PrefixServer Text
| PrefixUser Host
deriving (Eq, Show, Read, Ord, Generic)
data Msg command params = Msg
{ msgPrefix :: Maybe Prefix
, msgParams :: PList params }
instance Eq (PList params) => Eq (Msg command params) where
Msg a b == Msg c d = a == c && b == d
instance Show (PList params) => Show (Msg command params) where
show (Msg a b) = "Msg (" ++ show a ++ ") (" ++ show b ++ ")"
vacant :: Msg c '[]
vacant = Msg Nothing PNil
(<:>) :: x -> Msg c xs -> Msg c (x ': xs)
x <:> (Msg p xs) = Msg p (PCons x xs)
infixr 5 <:>
castMsg :: (KnownSymbol c1, KnownSymbol c2) => Msg c1 p -> Msg c2 p
castMsg (Msg c p) = Msg c p
data SomeMsg where
SomeMsg :: (KnownSymbol c, Parameter (PList p)) => Msg c p -> SomeMsg
class Parameter a where
render :: a -> ByteString
seize :: Parser a
instance Parameter Text where
render = encodeUtf8
seize = decodeUtf8 <$> do
x <- takeTill (\x -> isSpace x || x == ',')
if B.null x then empty else pure x
instance Parameter a => Parameter [a] where
render = mconcat . intersperse "," . map render
seize = sepBy seize (char ',')
instance Parameter a => Parameter (NonEmpty a) where
render (x :| []) = render x
render (x :| xs) = render (x : xs)
seize = fromList <$> sepBy1 seize (char ',')
instance Parameter a => Parameter (Maybe a) where
render (Just x) = render x
render Nothing = ""
seize = optional seize
instance (Parameter x, Parameter (PList xs))
=> Parameter (PList (x ': xs)) where
render (PCons x PNil) = render x
render (PCons x xs) =
case render xs of
"" -> render x
_ -> render x <> " " <> render xs
seize = PCons <$> seize <*> (skipSpace *> seize)
instance Parameter (PList '[]) where
render _ = ""
seize = pure PNil
data Unused (a :: Symbol) = Unused deriving (Show, Eq, Ord, Read, Generic)
instance KnownSymbol a => Parameter (Unused (a :: Symbol)) where
render _ = B.pack . symbolVal $ Proxy @a
seize = let x = B.pack $ symbolVal (Proxy @a) in Unused <$ string x
data Flag a = Set | Unset deriving (Show, Eq, Ord, Read, Generic)
instance KnownSymbol a => Parameter (Flag (a :: Symbol)) where
render Set = B.pack . symbolVal $ Proxy @a
render Unset = ""
seize = let x = B.pack $ symbolVal (Proxy @a)
in fromMaybe Unset <$> optional (Set <$ string x)
instance Parameter ByteString where
render = id
seize = takeByteString
instance Parameter Word where
render = render . T.pack . show
seize = decimal
instance Parameter Int where
render = render . T.pack . show
seize = decimal
instance Parameter Char where
render = render . T.singleton
seize = satisfy (not . isSpace)
instance Parameter Host where
render h = render
$ view hostNick h
<> maybe "" (T.cons '!') (view hostUser h)
<> maybe "" (T.cons '@') (view hostHost h)
seize = do
n <- takeTill (inClass " .!@\r\n")
p <- peekChar
case p of
Just c | c == '.' -> empty
_ -> Host (decodeUtf8 n)
<$> optional (decodeUtf8 <$>
(char '!' *> takeTill (inClass " @\r\n")))
<*> optional (decodeUtf8 <$>
(char '@' *> takeTill (inClass " \r\n")))
instance (Parameter a, Parameter b) => Parameter (a, b) where
render (a,b) = render a <> " " <> render b
seize = (,) <$> seize <*> (skipSpace *> seize)
instance (Parameter a, Parameter b) => Parameter (Either a b) where
render (Left x) = render x
render (Right x) = render x
seize = (Left <$> seize) <|> (Right <$> seize)
instance TypeError ('Text "Illegal IRC Parameter") => Parameter Void where
render = absurd
seize = empty
instance Parameter POSIXTime where
render x = let x' = truncate x :: Int
in B.pack . show $ x'
seize = do
(x :: Int) <- decimal
pure $ fromIntegral x
newtype SList a = SList { getSList :: [a] }
deriving (Eq, Show, Ord, Read, Functor, Applicative, Monad, Foldable,
Traversable, Semigroup, Monoid, Alternative, Generic)
instance Wrapped (SList a) where
type Unwrapped (SList a) = [a]
_Wrapped' = iso getSList SList
instance (t ~ SList b) => Rewrapped (SList a) t
instance IsList (SList a) where
type Item (SList a) = a
fromList = SList
toList = getSList
instance Parameter a => Parameter (SList a) where
render = mconcat . intersperse " " . map render . getSList
seize = SList <$> sepBy seize space
newtype CList a = CList { getCList :: [a] }
deriving (Eq, Show, Ord, Read, Functor, Applicative, Monad, Foldable,
Traversable, Semigroup, Monoid, Alternative, Generic)
instance Wrapped (CList a) where
type Unwrapped (CList a) = [a]
_Wrapped' = iso getCList CList
instance (t ~ CList b) => Rewrapped (CList a) t
instance IsList (CList a) where
type Item (CList a) = a
fromList = CList
toList = getCList
instance Parameter a => Parameter (CList a) where
render = mconcat . (":" :) . intersperse " " . map render . getCList
seize = CList <$> (char ':' *> sepBy seize space)
data PList a where
PNil :: PList '[]
PCons :: forall x xs. x -> PList xs -> PList (x ': xs)
instance Eq (PList '[]) where
PNil == PNil = True
instance (Eq x, Eq (PList xs)) => Eq (PList (x ': xs)) where
(PCons x xs) == (PCons y ys) = x == y && xs == ys
instance Show (PList '[]) where
show PNil = "PNil"
instance (Show x, Show (PList xs)) => Show (PList (x ': xs)) where
show (PCons x xs) = show x ++ " `PCons` " ++ show xs
phead :: Parameter x' => Lens (PList (x ': xs)) (PList (x' ': xs)) x x'
phead = lens (\(PCons x _) -> x) (\(PCons _ xs) x -> PCons x xs)
ptail :: Lens (PList (x ': xs)) (PList (x ': xs')) (PList xs) (PList xs')
ptail = lens (\(PCons _ xs) -> xs) (\(PCons x _) xs -> PCons x xs)
instance (Parameter x, Parameter x')
=> Field1 (PList (x ': xs))
(PList (x' ': xs)) x x'
where
_1 = phead
instance (Parameter x, Parameter x')
=> Field2 (PList (a ': x ': xs))
(PList (a ': x' ': xs)) x x'
where
_2 = ptail . phead
instance (Parameter x, Parameter x')
=> Field3 (PList (a ': b ': x ': xs))
(PList (a ': b ': x' ': xs)) x x'
where
_3 = ptail . ptail . phead
instance (Parameter x, Parameter x')
=> Field4 (PList (a ': b ': c ': x ': xs))
(PList (a ': b ': c ': x' ': xs)) x x'
where
_4 = ptail . ptail . ptail . phead
instance (Parameter x, Parameter x')
=> Field5 (PList (a ': b ': c ': d ': x ': xs))
(PList (a ': b ': c ': d ': x' ': xs)) x x'
where
_5 = ptail . ptail . ptail . ptail . phead
instance (Parameter x, Parameter x')
=> Field6 (PList (a ': b ': c ': d ': e ': x ': xs))
(PList (a ': b ': c ': d ': e ': x' ': xs)) x x'
where
_6 = ptail . ptail . ptail . ptail . ptail . phead
instance (Parameter x, Parameter x')
=> Field7 (PList (a ': b ': c ': d ': e ': f ': x ': xs))
(PList (a ': b ': c ': d ': e ': f ': x' ': xs)) x x'
where
_7 = ptail . ptail . ptail . ptail . ptail . ptail . phead
instance (Parameter x, Parameter x')
=> Field8 (PList (a ': b ': c ': d ': e ': f ': g ': x ': xs))
(PList (a ': b ': c ': d ': e ': f ': g ': x' ': xs)) x x'
where
_8 = ptail . ptail . ptail . ptail . ptail . ptail . ptail . phead
instance (Parameter x, Parameter x')
=> Field9 (PList (a ': b ': c ': d ': e ': f ': g ': h ': x ': xs))
(PList (a ': b ': c ': d ': e ': f ': g ': h ': x' ': xs)) x x'
where
_9 = ptail . ptail . ptail . ptail . ptail . ptail . ptail . ptail . phead
makeLensesFor [("msgParams", "params"), ("msgPrefix", "prefix")] ''Msg
type family Reverse' (acc :: [Type]) (xs :: [Type]) :: [Type]
type instance Reverse' acc '[] = acc
type instance Reverse' acc (x ': xs) = Reverse' (x ': acc) xs
class HReverse acc xs where
hReverse' :: PList acc -> PList xs -> PList (Reverse' acc xs)
instance HReverse acc '[] where
hReverse' = const
instance HReverse (x ': acc) xs => HReverse acc (x ': xs) where
hReverse' acc (PCons x xs) = hReverse' (PCons x acc) xs
class Build (xs :: [Type]) f where
build' :: Msg c xs -> f
instance (ys ~ Reverse' '[] xs, HReverse '[] xs) => Build xs (Msg c ys) where
build' (Msg a b) = Msg a (hReverse' PNil b)
instance Build (x ': xs) g => Build xs (x -> g) where
build' xs x = build' (x <:> xs)
build :: Build '[] f => f
build = build' vacant
buildPrefix :: Build '[] f => Prefix -> f
buildPrefix p = build' (vacant & prefix .~ Just p)
newtype Channel = Channel { getChannel :: Text }
deriving (Eq, Show, Ord, Read, IsString, Semigroup, Monoid, Generic)
makeWrapped ''Channel
instance Parameter Channel where
render = render . getChannel
seize = do
mark <- satisfy (inClass "&#")
name <- many1 $ satisfy (notInClass " \7,\n")
pure . Channel . T.pack $ mark : name
newtype Message = Message { getMessage :: Text }
deriving (Eq, Show, Ord, Read, IsString, Semigroup, Monoid, Generic)
makeWrapped ''Message
instance Parameter Message where
render = render . T.cons ':' . getMessage
seize = Message . decodeUtf8 <$> (char ':' *> takeTill (inClass "\n"))
newtype Modes = Modes { getModes :: [Char] } deriving (Generic)
makeWrapped ''Modes
instance Parameter Modes where
render = B.pack . getModes
seize = Modes <$> many1 (satisfy isAlpha_ascii)
data Token
= KeyValue Text Text
| PositiveToken Text
| NegativeToken Text
deriving (Eq, Show, Ord, Read, Generic)
makePrisms ''Token
instance Parameter Token where
render (PositiveToken t) = render . T.toUpper $ t
render (NegativeToken t) = render . T.cons '-' . T.toUpper $ t
render (KeyValue t v) = render (T.toUpper t <> "=" <> v)
seize = kv <|> neg <|> pos
where ident = T.pack <$> many1 (satisfy (inClass "A-Z"))
kv = KeyValue <$> ident
<*> (char '=' *> (decodeUtf8 <$> takeTill isSpace))
neg = NegativeToken <$> (char '-' *> ident)
pos = PositiveToken <$> ident
declareLenses [d|
data UReply = UReply
{ ureplyNick :: Nickname
, ureplyIsOp :: Bool
, ureplyIsAway :: Bool
, ureplyHostname :: Hostname
}
deriving (Eq, Show, Ord, Read, Generic)
|]
instance Parameter UReply where
render (UReply nick isop isaway host) =
render $ nick <> if isop then "*" else "" <> "="
<> if isaway then "-" else "+" <> host
seize = UReply
<$> seize
<*> option False (True <$ char '*')
<*> (char '=' *> ((True <$ char '-') <|> (False <$ char '+')))
<*> seize
declareLenses [d|
data Member a = Member
{ memberPrefix :: Maybe Char
, memberData :: a
}
deriving (Eq, Show, Ord, Read, Generic)
|]
instance Parameter a => Parameter (Member a) where
render (Member p c) = maybe "" B.singleton p <> (render c)
seize = Member <$> optional (satisfy (inClass "~&@%+")) <*> seize