module HsDev.Server.Message.Lisp (
	Msg,
	isLisp, msg,
	jsonMsg, lispMsg,

	decodeMsg, encodeMsg
	) where

import Control.Applicative
import Control.Lens
import Control.Monad
import Data.Aeson
import Data.Maybe
import Data.ByteString.Lazy.Char8 (ByteString)

import Data.Lisp

type Msg a = (Bool, a)

isLisp :: Lens' (Msg a) Bool
isLisp :: (Bool -> f Bool) -> Msg a -> f (Msg a)
isLisp = (Bool -> f Bool) -> Msg a -> f (Msg a)
forall s t a b. Field1 s t a b => Lens s t a b
_1

msg :: Lens (Msg a) (Msg b) a b
msg :: (a -> f b) -> Msg a -> f (Msg b)
msg = (a -> f b) -> Msg a -> f (Msg b)
forall s t a b. Field2 s t a b => Lens s t a b
_2

jsonMsg :: a -> Msg a
jsonMsg :: a -> Msg a
jsonMsg = (,) Bool
False

lispMsg :: a -> Msg a
lispMsg :: a -> Msg a
lispMsg = (,) Bool
True

-- | Decode lisp or json
decodeMsg :: FromJSON a => ByteString -> Either (Msg String) (Msg a)
decodeMsg :: ByteString -> Either (Msg String) (Msg a)
decodeMsg ByteString
bstr = ASetter
  (Either String (Msg a))
  (Either (Msg String) (Msg a))
  String
  (Msg String)
-> (String -> Msg String)
-> Either String (Msg a)
-> Either (Msg String) (Msg a)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (Either String (Msg a))
  (Either (Msg String) (Msg a))
  String
  (Msg String)
forall a c b. Prism (Either a c) (Either b c) a b
_Left String -> Msg String
forall a. a -> Msg a
decodeType' Either String (Msg a)
decodeMsg' where
	decodeType' :: a -> Msg a
decodeType'
		| Bool
isLisp' = a -> Msg a
forall a. a -> Msg a
lispMsg
		| Bool
otherwise = a -> Msg a
forall a. a -> Msg a
jsonMsg
	decodeMsg' :: Either String (Msg a)
decodeMsg' = (a -> Msg a
forall a. a -> Msg a
lispMsg (a -> Msg a) -> Either String a -> Either String (Msg a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
decodeLisp ByteString
bstr) Either String (Msg a)
-> Either String (Msg a) -> Either String (Msg a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> Msg a
forall a. a -> Msg a
jsonMsg (a -> Msg a) -> Either String a -> Either String (Msg a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bstr)
	isLisp' :: Bool
isLisp' = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe Bool -> Maybe Bool -> Maybe Bool
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus ((ByteString -> Either String Value) -> Bool -> Maybe Bool
try' ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode Bool
False) ((ByteString -> Either String Value) -> Bool -> Maybe Bool
try' ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
decodeLisp Bool
True)
	try' :: (ByteString -> Either String Value) -> Bool -> Maybe Bool
	try' :: (ByteString -> Either String Value) -> Bool -> Maybe Bool
try' ByteString -> Either String Value
f Bool
l = (String -> Maybe Bool)
-> (Value -> Maybe Bool) -> Either String Value -> Maybe Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Bool -> String -> Maybe Bool
forall a b. a -> b -> a
const Maybe Bool
forall a. Maybe a
Nothing) (Maybe Bool -> Value -> Maybe Bool
forall a b. a -> b -> a
const (Maybe Bool -> Value -> Maybe Bool)
-> Maybe Bool -> Value -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
l) (Either String Value -> Maybe Bool)
-> Either String Value -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String Value
f ByteString
bstr

-- | Encode lisp or json
encodeMsg :: ToJSON a => Msg a -> ByteString
encodeMsg :: Msg a -> ByteString
encodeMsg Msg a
m
	| Getting Bool (Msg a) Bool -> Msg a -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool (Msg a) Bool
forall a. Lens' (Msg a) Bool
isLisp Msg a
m = a -> ByteString
forall a. ToJSON a => a -> ByteString
encodeLisp (a -> ByteString) -> a -> ByteString
forall a b. (a -> b) -> a -> b
$ Getting a (Msg a) a -> Msg a -> a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting a (Msg a) a
forall a b. Lens (Msg a) (Msg b) a b
msg Msg a
m
	| Bool
otherwise = a -> ByteString
forall a. ToJSON a => a -> ByteString
encode (a -> ByteString) -> a -> ByteString
forall a b. (a -> b) -> a -> b
$ Getting a (Msg a) a -> Msg a -> a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting a (Msg a) a
forall a b. Lens (Msg a) (Msg b) a b
msg Msg a
m