{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.Yak
( emit
, emitSome
, Fetch
, fetch
, fetch'
, T.build
, T.buildPrefix
, T.vacant
, T.castMsg
, (T.<:>)
, module Network.Yak.Types
) where
import Control.Applicative
import Data.Attoparsec.ByteString.Char8
import Data.ByteString.Char8 (ByteString)
import Data.Maybe
import Data.Proxy
import Data.Text.Encoding
import GHC.TypeLits
import Network.Yak.Types hiding (build, buildPrefix, vacant, castMsg, (<:>))
import qualified Network.Yak.Types as T
import qualified Data.ByteString.Char8 as B
emit :: forall c p. (Parameter (PList p), KnownSymbol c)
=> Msg c p -> ByteString
emit Msg{..} = fromMaybe ""
(flip mappend " " . mappend ":" . rpfx <$> msgPrefix)
<> (B.pack $ symbolVal (Proxy @c))
<> " "
<> render msgParams
<> "\n"
where rpfx (PrefixServer x) = render x
rpfx (PrefixUser h) = render h
emitSome :: SomeMsg -> ByteString
emitSome (SomeMsg r) = emit r
class Fetch a where
fetch :: ByteString -> Maybe a
instance (Parameter (PList p), KnownSymbol c) => Fetch (Msg c p) where
fetch = either (const Nothing) Just . parseOnly fetch'
instance (Fetch a, Fetch b) => Fetch (Either a b) where
fetch x =
case fetch @a x of
Just l -> Just (Left l)
Nothing -> Right <$> fetch x
fetch' :: forall c p. (Parameter (PList p), KnownSymbol c) => Parser (Msg c p)
fetch' = Msg
<$> optional (char ':' *> pfx)
<*> (skipSpace *> cmd *> skipSpace *> seize)
where cmd = string . B.pack . symbolVal $ Proxy @c
pfx = (PrefixUser <$> seize) <|> (PrefixServer <$> srv)
srv = decodeUtf8 <$> takeTill isSpace