module Data.Lisp (
	Lisp(..),
	lisp,
	encodeLisp, decodeLisp
	) where

import Prelude hiding (String, Bool)
import qualified Prelude as P (String, Bool)

import Data.Aeson (ToJSON(..), FromJSON(..), (.=))
import qualified Data.Aeson as A
import Data.Aeson.Types (parseMaybe, parseEither)
import Data.ByteString.Lazy (ByteString)
import Data.Char (isAlpha, isDigit)
import Data.Either (partitionEithers)
import qualified Data.HashMap.Strict as HM
import Data.List (unfoldr)
import Data.Scientific
import Data.String (fromString)
import qualified Data.Text as T (unpack)
import qualified Data.Text.Lazy as LT (pack, unpack)
import qualified Data.Text.Lazy.Encoding as LT (encodeUtf8, decodeUtf8)
import qualified Text.ParserCombinators.ReadP as R
import Text.Read (readMaybe)
import qualified Data.Vector as V

data Lisp =
	Null |
	Bool P.Bool |
	Symbol P.String |
	String P.String |
	Number Scientific |
	List [Lisp]
		deriving (Lisp -> Lisp -> Bool
(Lisp -> Lisp -> Bool) -> (Lisp -> Lisp -> Bool) -> Eq Lisp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Lisp -> Lisp -> Bool
$c/= :: Lisp -> Lisp -> Bool
== :: Lisp -> Lisp -> Bool
$c== :: Lisp -> Lisp -> Bool
Eq)

readable :: Read a => Int -> R.ReadP a
readable :: Int -> ReadP a
readable = ReadS a -> ReadP a
forall a. ReadS a -> ReadP a
R.readS_to_P (ReadS a -> ReadP a) -> (Int -> ReadS a) -> Int -> ReadP a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ReadS a
forall a. Read a => Int -> ReadS a
readsPrec

lisp :: Int -> R.ReadP Lisp
lisp :: Int -> ReadP Lisp
lisp Int
n = [ReadP Lisp] -> ReadP Lisp
forall a. [ReadP a] -> ReadP a
R.choice [
	do
		String
s <- ReadP String
symbol
		Lisp -> ReadP Lisp
forall (m :: * -> *) a. Monad m => a -> m a
return (Lisp -> ReadP Lisp) -> Lisp -> ReadP Lisp
forall a b. (a -> b) -> a -> b
$ case String
s of
			String
"null" -> Lisp
Null
			String
"true" -> Bool -> Lisp
Bool Bool
True
			String
"false" -> Bool -> Lisp
Bool Bool
False
			String
_ -> String -> Lisp
Symbol String
s,
	(String -> Lisp) -> ReadP String -> ReadP Lisp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Lisp
String ReadP String
string,
	(Scientific -> Lisp) -> ReadP Scientific -> ReadP Lisp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Scientific -> Lisp
Number ReadP Scientific
number,
	([Lisp] -> Lisp) -> ReadP [Lisp] -> ReadP Lisp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Lisp] -> Lisp
List ReadP [Lisp]
list]
	where
		symbol :: R.ReadP P.String
		symbol :: ReadP String
symbol = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> ReadP [String] -> ReadP String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ReadP String] -> ReadP [String]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
			String -> ReadP String -> ReadP String
forall a. a -> ReadP a -> ReadP a
R.option [] (Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> String) -> ReadP Char -> ReadP String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ReadP Char
R.char Char
':'),
			Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> String) -> ReadP Char -> ReadP String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP Char
R.satisfy Char -> Bool
isAlpha,
			(Char -> Bool) -> ReadP String
R.munch (\Char
ch -> Char -> Bool
isAlpha Char
ch Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
ch Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')]

		string :: R.ReadP P.String
		string :: ReadP String
string = (ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
R.<++ ReadP String
forall a. ReadP a
R.pfail) (ReadP String -> ReadP String) -> ReadP String -> ReadP String
forall a b. (a -> b) -> a -> b
$ do
			(Char
'\"':String
_) <- ReadP String
R.look
			Int -> ReadP String
forall a. Read a => Int -> ReadP a
readable Int
n

		number :: R.ReadP Scientific
		number :: ReadP Scientific
number = do
			String
s <- (Char -> Bool) -> ReadP String
R.munch1 (\Char
ch -> Char -> Bool
isDigit Char
ch Bool -> Bool -> Bool
|| Char
ch Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'e', Char
'E', Char
'.', Char
'+', Char
'-'])
			ReadP Scientific
-> (Scientific -> ReadP Scientific)
-> Maybe Scientific
-> ReadP Scientific
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReadP Scientific
forall a. ReadP a
R.pfail Scientific -> ReadP Scientific
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Scientific -> ReadP Scientific)
-> Maybe Scientific -> ReadP Scientific
forall a b. (a -> b) -> a -> b
$ String -> Maybe Scientific
forall a. Read a => String -> Maybe a
readMaybe String
s

		list :: R.ReadP [Lisp]
		list :: ReadP [Lisp]
list = ReadP Char -> ReadP Char -> ReadP [Lisp] -> ReadP [Lisp]
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
R.between (Char -> ReadP Char
R.char Char
'(') (Char -> ReadP Char
R.char Char
')') (ReadP [Lisp] -> ReadP [Lisp]) -> ReadP [Lisp] -> ReadP [Lisp]
forall a b. (a -> b) -> a -> b
$ ReadP Lisp -> ReadP () -> ReadP [Lisp]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
R.sepBy (Int -> ReadP Lisp
lisp Int
n) ReadP ()
R.skipSpaces

instance Read Lisp where
	readsPrec :: Int -> ReadS Lisp
readsPrec = ReadP Lisp -> ReadS Lisp
forall a. ReadP a -> ReadS a
R.readP_to_S (ReadP Lisp -> ReadS Lisp)
-> (Int -> ReadP Lisp) -> Int -> ReadS Lisp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ReadP Lisp
lisp

instance Show Lisp where
	show :: Lisp -> String
show Lisp
Null = String
"null"
	show (Bool Bool
b)
		| Bool
b = String
"true"
		| Bool
otherwise = String
"false"
	show (Symbol String
s) = String
s
	show (String String
s) = ShowS
forall a. Show a => a -> String
show String
s
	show (Number Scientific
n) = (Double -> String)
-> (Integer -> String) -> Either Double Integer -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Double -> String
forall a. Show a => a -> String
show Integer -> String
forall a. Show a => a -> String
show (Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
n :: Either Double Integer)
	show (List [Lisp]
vs) = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((Lisp -> String) -> [Lisp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Lisp -> String
forall a. Show a => a -> String
show [Lisp]
vs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

instance ToJSON Lisp where
	toJSON :: Lisp -> Value
toJSON Lisp
Null = Value -> Value
forall a. ToJSON a => a -> Value
toJSON Value
A.Null
	toJSON (Bool Bool
b) = Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
b
	toJSON (Symbol String
s) = String -> Value
forall a. ToJSON a => a -> Value
toJSON String
s
	toJSON (String String
s) = String -> Value
forall a. ToJSON a => a -> Value
toJSON String
s
	toJSON (Number Scientific
n) = Scientific -> Value
forall a. ToJSON a => a -> Value
toJSON Scientific
n
	toJSON (List [Lisp]
vs)
		| [(String, Lisp)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Lisp)]
keywords = [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (Lisp -> Value) -> [Lisp] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Lisp -> Value
forall a. ToJSON a => a -> Value
toJSON [Lisp]
vals
		| [Lisp] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Lisp]
vals = Value
keywordsObject
		| Bool
otherwise = [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (Lisp -> Value) -> [Lisp] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Lisp -> Value
forall a. ToJSON a => a -> Value
toJSON [Lisp]
vals [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value
keywordsObject]
		where
			([Lisp]
vals, [(String, Lisp)]
keywords) = [Either Lisp (String, Lisp)] -> ([Lisp], [(String, Lisp)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Lisp (String, Lisp)] -> ([Lisp], [(String, Lisp)]))
-> [Either Lisp (String, Lisp)] -> ([Lisp], [(String, Lisp)])
forall a b. (a -> b) -> a -> b
$ ([Lisp] -> Maybe (Either Lisp (String, Lisp), [Lisp]))
-> [Lisp] -> [Either Lisp (String, Lisp)]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [Lisp] -> Maybe (Either Lisp (String, Lisp), [Lisp])
cutKeyword [Lisp]
vs
			keywordsObject :: Value
keywordsObject = [Pair] -> Value
A.object [String -> Text
forall a. IsString a => String -> a
fromString (ShowS
dropColon String
k) Text -> Lisp -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Lisp
v | (String
k, Lisp
v) <- [(String, Lisp)]
keywords]

			dropColon :: P.String -> P.String
			dropColon :: ShowS
dropColon (Char
':' : String
s) = String
s
			dropColon String
s = String
s

			cutKeyword :: [Lisp] -> Maybe (Either Lisp (P.String, Lisp), [Lisp])
			cutKeyword :: [Lisp] -> Maybe (Either Lisp (String, Lisp), [Lisp])
cutKeyword [] = Maybe (Either Lisp (String, Lisp), [Lisp])
forall a. Maybe a
Nothing
			cutKeyword (Symbol String
s : []) = (Either Lisp (String, Lisp), [Lisp])
-> Maybe (Either Lisp (String, Lisp), [Lisp])
forall a. a -> Maybe a
Just ((String, Lisp) -> Either Lisp (String, Lisp)
forall a b. b -> Either a b
Right (String
s, Lisp
Null), [])
			cutKeyword (Symbol String
s : Symbol String
h : [Lisp]
hs) = (Either Lisp (String, Lisp), [Lisp])
-> Maybe (Either Lisp (String, Lisp), [Lisp])
forall a. a -> Maybe a
Just ((String, Lisp) -> Either Lisp (String, Lisp)
forall a b. b -> Either a b
Right (String
s, Lisp
Null), String -> Lisp
Symbol String
h Lisp -> [Lisp] -> [Lisp]
forall a. a -> [a] -> [a]
: [Lisp]
hs)
			cutKeyword (Symbol String
s : Lisp
h : [Lisp]
hs) = (Either Lisp (String, Lisp), [Lisp])
-> Maybe (Either Lisp (String, Lisp), [Lisp])
forall a. a -> Maybe a
Just ((String, Lisp) -> Either Lisp (String, Lisp)
forall a b. b -> Either a b
Right (String
s, Lisp
h), [Lisp]
hs)
			cutKeyword (Lisp
h : [Lisp]
hs) = (Either Lisp (String, Lisp), [Lisp])
-> Maybe (Either Lisp (String, Lisp), [Lisp])
forall a. a -> Maybe a
Just (Lisp -> Either Lisp (String, Lisp)
forall a b. a -> Either a b
Left Lisp
h, [Lisp]
hs)

instance FromJSON Lisp where
	parseJSON :: Value -> Parser Lisp
parseJSON Value
A.Null = Lisp -> Parser Lisp
forall (m :: * -> *) a. Monad m => a -> m a
return Lisp
Null
	parseJSON (A.Bool Bool
b) = Lisp -> Parser Lisp
forall (m :: * -> *) a. Monad m => a -> m a
return (Lisp -> Parser Lisp) -> Lisp -> Parser Lisp
forall a b. (a -> b) -> a -> b
$ Bool -> Lisp
Bool Bool
b
	parseJSON (A.String Text
s) = Lisp -> Parser Lisp
forall (m :: * -> *) a. Monad m => a -> m a
return (Lisp -> Parser Lisp) -> Lisp -> Parser Lisp
forall a b. (a -> b) -> a -> b
$ String -> Lisp
String (String -> Lisp) -> String -> Lisp
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s
	parseJSON (A.Number Scientific
n) = Lisp -> Parser Lisp
forall (m :: * -> *) a. Monad m => a -> m a
return (Lisp -> Parser Lisp) -> Lisp -> Parser Lisp
forall a b. (a -> b) -> a -> b
$ Scientific -> Lisp
Number Scientific
n
	parseJSON (A.Array Array
vs) = ([Lisp] -> Lisp) -> Parser [Lisp] -> Parser Lisp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Lisp] -> Lisp
List (Parser [Lisp] -> Parser Lisp) -> Parser [Lisp] -> Parser Lisp
forall a b. (a -> b) -> a -> b
$ (Value -> Parser Lisp) -> [Value] -> Parser [Lisp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Parser Lisp
forall a. FromJSON a => Value -> Parser a
parseJSON ([Value] -> Parser [Lisp]) -> [Value] -> Parser [Lisp]
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
vs
	parseJSON (A.Object Object
obj) = ([[Lisp]] -> Lisp) -> Parser [[Lisp]] -> Parser Lisp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Lisp] -> Lisp
List ([Lisp] -> Lisp) -> ([[Lisp]] -> [Lisp]) -> [[Lisp]] -> Lisp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Lisp]] -> [Lisp]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (Parser [[Lisp]] -> Parser Lisp) -> Parser [[Lisp]] -> Parser Lisp
forall a b. (a -> b) -> a -> b
$ (Pair -> Parser [Lisp]) -> [Pair] -> Parser [[Lisp]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Text
k, Value
v) -> [Parser Lisp] -> Parser [Lisp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Lisp -> Parser Lisp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lisp -> Parser Lisp) -> Lisp -> Parser Lisp
forall a b. (a -> b) -> a -> b
$ String -> Lisp
Symbol (Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Text -> String
T.unpack Text
k), Value -> Parser Lisp
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v]) ([Pair] -> Parser [[Lisp]]) -> [Pair] -> Parser [[Lisp]]
forall a b. (a -> b) -> a -> b
$ Object -> [Pair]
forall k v. HashMap k v -> [(k, v)]
HM.toList Object
obj

decodeLisp :: FromJSON a => ByteString -> Either P.String a
decodeLisp :: ByteString -> Either String a
decodeLisp ByteString
str = do
	Lisp
sexp <- Either String Lisp
-> (Lisp -> Either String Lisp) -> Maybe Lisp -> Either String Lisp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Lisp
forall a b. a -> Either a b
Left String
"Not a s-exp") Lisp -> Either String Lisp
forall a b. b -> Either a b
Right (Maybe Lisp -> Either String Lisp)
-> (ByteString -> Maybe Lisp) -> ByteString -> Either String Lisp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Lisp
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Lisp)
-> (ByteString -> String) -> ByteString -> Maybe Lisp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
LT.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LT.decodeUtf8 (ByteString -> Either String Lisp)
-> ByteString -> Either String Lisp
forall a b. (a -> b) -> a -> b
$ ByteString
str
	(Value -> Parser a) -> Value -> Either String a
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Either String a) -> Value -> Either String a
forall a b. (a -> b) -> a -> b
$ Lisp -> Value
forall a. ToJSON a => a -> Value
toJSON (Lisp
sexp :: Lisp)

encodeLisp :: ToJSON a => a -> ByteString
encodeLisp :: a -> ByteString
encodeLisp a
r = Text -> ByteString
LT.encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
LT.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> (Lisp -> String) -> Maybe Lisp -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
	String
"(:error \"can't convert to s-exp\")"
	(Lisp -> String
forall a. Show a => a -> String
show :: Lisp -> P.String)
	((Value -> Parser Lisp) -> Value -> Maybe Lisp
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser Lisp
forall a. FromJSON a => Value -> Parser a
parseJSON (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
r))