{-# LANGUAGE OverloadedStrings, DeriveFunctor, TypeSynonymInstances, FlexibleInstances, TemplateHaskell #-}

module HsDev.Server.Message (
	Message(..), messageId, message,
	messagesById,
	Notification(..), Result(..), ResultPart(..),
	Response(..), isNotification, result, responseError,
	groupResponses,
	decodeMessage, encodeMessage,

	module HsDev.Server.Message.Lisp
	) where

import Control.Applicative
import Control.Lens (makeLenses)
import Control.Monad (join)
import Data.Aeson hiding (Error, Result)
import Data.Either (lefts, isRight)
import Data.List (unfoldr)
import Data.ByteString.Lazy.Char8 (ByteString)

import HsDev.Types
import HsDev.Util ((.::), (.::?), objectUnion)
import HsDev.Server.Message.Lisp

-- | Message with id to link request and response
data Message a = Message {
	Message a -> Maybe String
_messageId :: Maybe String,
	Message a -> a
_message :: a }
		deriving (Message a -> Message a -> Bool
(Message a -> Message a -> Bool)
-> (Message a -> Message a -> Bool) -> Eq (Message a)
forall a. Eq a => Message a -> Message a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message a -> Message a -> Bool
$c/= :: forall a. Eq a => Message a -> Message a -> Bool
== :: Message a -> Message a -> Bool
$c== :: forall a. Eq a => Message a -> Message a -> Bool
Eq, Eq (Message a)
Eq (Message a)
-> (Message a -> Message a -> Ordering)
-> (Message a -> Message a -> Bool)
-> (Message a -> Message a -> Bool)
-> (Message a -> Message a -> Bool)
-> (Message a -> Message a -> Bool)
-> (Message a -> Message a -> Message a)
-> (Message a -> Message a -> Message a)
-> Ord (Message a)
Message a -> Message a -> Bool
Message a -> Message a -> Ordering
Message a -> Message a -> Message a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Message a)
forall a. Ord a => Message a -> Message a -> Bool
forall a. Ord a => Message a -> Message a -> Ordering
forall a. Ord a => Message a -> Message a -> Message a
min :: Message a -> Message a -> Message a
$cmin :: forall a. Ord a => Message a -> Message a -> Message a
max :: Message a -> Message a -> Message a
$cmax :: forall a. Ord a => Message a -> Message a -> Message a
>= :: Message a -> Message a -> Bool
$c>= :: forall a. Ord a => Message a -> Message a -> Bool
> :: Message a -> Message a -> Bool
$c> :: forall a. Ord a => Message a -> Message a -> Bool
<= :: Message a -> Message a -> Bool
$c<= :: forall a. Ord a => Message a -> Message a -> Bool
< :: Message a -> Message a -> Bool
$c< :: forall a. Ord a => Message a -> Message a -> Bool
compare :: Message a -> Message a -> Ordering
$ccompare :: forall a. Ord a => Message a -> Message a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Message a)
Ord, Int -> Message a -> ShowS
[Message a] -> ShowS
Message a -> String
(Int -> Message a -> ShowS)
-> (Message a -> String)
-> ([Message a] -> ShowS)
-> Show (Message a)
forall a. Show a => Int -> Message a -> ShowS
forall a. Show a => [Message a] -> ShowS
forall a. Show a => Message a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Message a] -> ShowS
$cshowList :: forall a. Show a => [Message a] -> ShowS
show :: Message a -> String
$cshow :: forall a. Show a => Message a -> String
showsPrec :: Int -> Message a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Message a -> ShowS
Show, a -> Message b -> Message a
(a -> b) -> Message a -> Message b
(forall a b. (a -> b) -> Message a -> Message b)
-> (forall a b. a -> Message b -> Message a) -> Functor Message
forall a b. a -> Message b -> Message a
forall a b. (a -> b) -> Message a -> Message b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Message b -> Message a
$c<$ :: forall a b. a -> Message b -> Message a
fmap :: (a -> b) -> Message a -> Message b
$cfmap :: forall a b. (a -> b) -> Message a -> Message b
Functor)

makeLenses ''Message

instance ToJSON a => ToJSON (Message a) where
	toJSON :: Message a -> Value
toJSON (Message Maybe String
i a
m) = [Pair] -> Value
object [Text
"id" Text -> Maybe String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe String
i] Value -> Value -> Value
`objectUnion` a -> Value
forall a. ToJSON a => a -> Value
toJSON a
m

instance FromJSON a => FromJSON (Message a) where
	parseJSON :: Value -> Parser (Message a)
parseJSON = String
-> (Object -> Parser (Message a)) -> Value -> Parser (Message a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"message" ((Object -> Parser (Message a)) -> Value -> Parser (Message a))
-> (Object -> Parser (Message a)) -> Value -> Parser (Message a)
forall a b. (a -> b) -> a -> b
$ \Object
v ->
		Maybe String -> a -> Message a
forall a. Maybe String -> a -> Message a
Message (Maybe String -> a -> Message a)
-> Parser (Maybe String) -> Parser (a -> Message a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (Maybe String) -> Maybe String)
-> Parser (Maybe (Maybe String)) -> Parser (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe String) -> Maybe String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Object
v Object -> Text -> Parser (Maybe (Maybe String))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.::? Text
"id") Parser (a -> Message a) -> Parser a -> Parser (Message a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
v)

instance Foldable Message where
	foldMap :: (a -> m) -> Message a -> m
foldMap a -> m
f (Message Maybe String
_ a
m) = a -> m
f a
m

instance Traversable Message where
	traverse :: (a -> f b) -> Message a -> f (Message b)
traverse a -> f b
f (Message Maybe String
i a
m) = Maybe String -> b -> Message b
forall a. Maybe String -> a -> Message a
Message Maybe String
i (b -> Message b) -> f b -> f (Message b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
m

-- | Get messages by id
messagesById :: Maybe String -> [Message a] -> [a]
messagesById :: Maybe String -> [Message a] -> [a]
messagesById Maybe String
i = (Message a -> a) -> [Message a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Message a -> a
forall a. Message a -> a
_message ([Message a] -> [a])
-> ([Message a] -> [Message a]) -> [Message a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message a -> Bool) -> [Message a] -> [Message a]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
i) (Maybe String -> Bool)
-> (Message a -> Maybe String) -> Message a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message a -> Maybe String
forall a. Message a -> Maybe String
_messageId)

-- | Notification from server
newtype Notification = Notification Value deriving (Notification -> Notification -> Bool
(Notification -> Notification -> Bool)
-> (Notification -> Notification -> Bool) -> Eq Notification
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Notification -> Notification -> Bool
$c/= :: Notification -> Notification -> Bool
== :: Notification -> Notification -> Bool
$c== :: Notification -> Notification -> Bool
Eq, Int -> Notification -> ShowS
[Notification] -> ShowS
Notification -> String
(Int -> Notification -> ShowS)
-> (Notification -> String)
-> ([Notification] -> ShowS)
-> Show Notification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Notification] -> ShowS
$cshowList :: [Notification] -> ShowS
show :: Notification -> String
$cshow :: Notification -> String
showsPrec :: Int -> Notification -> ShowS
$cshowsPrec :: Int -> Notification -> ShowS
Show)

instance ToJSON Notification where
	toJSON :: Notification -> Value
toJSON (Notification Value
v) = [Pair] -> Value
object [Text
"notify" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
v]

instance FromJSON Notification where
	parseJSON :: Value -> Parser Notification
parseJSON = String
-> (Object -> Parser Notification) -> Value -> Parser Notification
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"notification" ((Object -> Parser Notification) -> Value -> Parser Notification)
-> (Object -> Parser Notification) -> Value -> Parser Notification
forall a b. (a -> b) -> a -> b
$ \Object
v -> Value -> Notification
Notification (Value -> Notification) -> Parser Value -> Parser Notification
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.:: Text
"notify"

-- | Result from server
data Result =
	Result Value |
	-- ^ Result
	Error HsDevError
	-- ^ Error
		deriving (Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show)

instance ToJSON Result where
	toJSON :: Result -> Value
toJSON (Result Value
r) = [Pair] -> Value
object [Text
"result" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
r]
	toJSON (Error HsDevError
e) = HsDevError -> Value
forall a. ToJSON a => a -> Value
toJSON HsDevError
e

instance FromJSON Result where
	parseJSON :: Value -> Parser Result
parseJSON Value
j = (String -> (Object -> Parser Result) -> Value -> Parser Result
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"result" (\Object
v -> (Value -> Result
Result (Value -> Result) -> Parser Value -> Parser Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.:: Text
"result")) Value
j) Parser Result -> Parser Result -> Parser Result
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (HsDevError -> Result
Error (HsDevError -> Result) -> Parser HsDevError -> Parser Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser HsDevError
forall a. FromJSON a => Value -> Parser a
parseJSON Value
j)

-- | Part of result list, returns via notification
newtype ResultPart = ResultPart Value

instance ToJSON ResultPart where
	toJSON :: ResultPart -> Value
toJSON (ResultPart Value
r) = [Pair] -> Value
object [Text
"result-part" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
r]

instance FromJSON ResultPart where
	parseJSON :: Value -> Parser ResultPart
parseJSON = String
-> (Object -> Parser ResultPart) -> Value -> Parser ResultPart
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"result-part" ((Object -> Parser ResultPart) -> Value -> Parser ResultPart)
-> (Object -> Parser ResultPart) -> Value -> Parser ResultPart
forall a b. (a -> b) -> a -> b
$ \Object
v -> Value -> ResultPart
ResultPart (Value -> ResultPart) -> Parser Value -> Parser ResultPart
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.:: Text
"result-part"

newtype Response = Response { Response -> Either Notification Result
unResponse :: Either Notification Result } deriving (Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> String
$cshow :: Response -> String
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show)

isNotification :: Response -> Bool
isNotification :: Response -> Bool
isNotification = (Notification -> Bool)
-> (Result -> Bool) -> Either Notification Result -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Notification -> Bool
forall a b. a -> b -> a
const Bool
True) (Bool -> Result -> Bool
forall a b. a -> b -> a
const Bool
False) (Either Notification Result -> Bool)
-> (Response -> Either Notification Result) -> Response -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Either Notification Result
unResponse

result :: ToJSON a => a -> Response
result :: a -> Response
result = Either Notification Result -> Response
Response (Either Notification Result -> Response)
-> (a -> Either Notification Result) -> a -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Either Notification Result
forall a b. b -> Either a b
Right (Result -> Either Notification Result)
-> (a -> Result) -> a -> Either Notification Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Result
Result (Value -> Result) -> (a -> Value) -> a -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON

responseError :: HsDevError -> Response
responseError :: HsDevError -> Response
responseError = Either Notification Result -> Response
Response (Either Notification Result -> Response)
-> (HsDevError -> Either Notification Result)
-> HsDevError
-> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Either Notification Result
forall a b. b -> Either a b
Right (Result -> Either Notification Result)
-> (HsDevError -> Result)
-> HsDevError
-> Either Notification Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsDevError -> Result
Error

instance ToJSON Response where
	toJSON :: Response -> Value
toJSON (Response (Left Notification
n)) = Notification -> Value
forall a. ToJSON a => a -> Value
toJSON Notification
n
	toJSON (Response (Right Result
r)) = Result -> Value
forall a. ToJSON a => a -> Value
toJSON Result
r

instance FromJSON Response where
	parseJSON :: Value -> Parser Response
parseJSON Value
v = Either Notification Result -> Response
Response (Either Notification Result -> Response)
-> Parser (Either Notification Result) -> Parser Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Notification -> Either Notification Result
forall a b. a -> Either a b
Left (Notification -> Either Notification Result)
-> Parser Notification -> Parser (Either Notification Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Notification
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v) Parser (Either Notification Result)
-> Parser (Either Notification Result)
-> Parser (Either Notification Result)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Result -> Either Notification Result
forall a b. b -> Either a b
Right (Result -> Either Notification Result)
-> Parser Result -> Parser (Either Notification Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Result
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v))

groupResponses :: [Response] -> [([Notification], Result)]
groupResponses :: [Response] -> [([Notification], Result)]
groupResponses = ([Response] -> Maybe (([Notification], Result), [Response]))
-> [Response] -> [([Notification], Result)]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [Response] -> Maybe (([Notification], Result), [Response])
break' where
	break' :: [Response] -> Maybe (([Notification], Result), [Response])
	break' :: [Response] -> Maybe (([Notification], Result), [Response])
break' [] = Maybe (([Notification], Result), [Response])
forall a. Maybe a
Nothing
	break' [Response]
cs =  (([Notification], Result), [Response])
-> Maybe (([Notification], Result), [Response])
forall a. a -> Maybe a
Just (([Either Notification Result] -> [Notification]
forall a b. [Either a b] -> [a]
lefts ((Response -> Either Notification Result)
-> [Response] -> [Either Notification Result]
forall a b. (a -> b) -> [a] -> [b]
map Response -> Either Notification Result
unResponse [Response]
ns), Result
r), Int -> [Response] -> [Response]
forall a. Int -> [a] -> [a]
drop Int
1 [Response]
cs') where
		([Response]
ns, [Response]
cs') = (Response -> Bool) -> [Response] -> ([Response], [Response])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Either Notification Result -> Bool
forall a b. Either a b -> Bool
isRight (Either Notification Result -> Bool)
-> (Response -> Either Notification Result) -> Response -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Either Notification Result
unResponse) [Response]
cs
		r :: Result
r = case [Response]
cs' of
			(Response (Right Result
r') : [Response]
_) -> Result
r'
			[] -> HsDevError -> Result
Error (HsDevError -> Result) -> HsDevError -> Result
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
OtherError String
"groupResponses: no result"
			[Response]
_ -> String -> Result
forall a. HasCallStack => String -> a
error String
"groupResponses: impossible happened"

-- | Decode lisp or json request
decodeMessage :: FromJSON a => ByteString -> Either (Msg String) (Msg (Message a))
decodeMessage :: ByteString -> Either (Msg String) (Msg (Message a))
decodeMessage = ByteString -> Either (Msg String) (Msg (Message a))
forall a. FromJSON a => ByteString -> Either (Msg String) (Msg a)
decodeMsg

encodeMessage :: ToJSON a => Msg (Message a) -> ByteString
encodeMessage :: Msg (Message a) -> ByteString
encodeMessage = Msg (Message a) -> ByteString
forall a. ToJSON a => Msg a -> ByteString
encodeMsg