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
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
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