Lisp.hs

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

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

import Control.Applicative
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 (Eq)

readable :: Read a => Int -> R.ReadP a
readable = R.readS_to_P . readsPrec

lisp :: Int -> R.ReadP Lisp
lisp n = R.choice [
	do
		s <- symbol
		return $ case s of
			"null" -> Null
			"true" -> Bool True
			"false" -> Bool False
			_ -> Symbol s,
	fmap String string,
	fmap Number number,
	fmap List list]
	where
		symbol :: R.ReadP P.String
		symbol = concat <$> sequence [
			R.option [] (pure <$> R.char ':'),
			pure <$> R.satisfy isAlpha,
			R.munch (\ch -> isAlpha ch || isDigit ch || ch == '-')]

		string :: R.ReadP P.String
		string = (R.<++ R.pfail) $ do
			('"':_) <- R.look
			readable n

		number :: R.ReadP Scientific
		number = do
			s <- R.munch1 (\ch -> isDigit ch || ch `elem` ['e', 'E', '.', '+', '-'])
			maybe R.pfail return $ readMaybe s

		list :: R.ReadP [Lisp]
		list = R.between (R.char '(') (R.char ')') $ R.sepBy (lisp n) R.skipSpaces

instance Read Lisp where
	readsPrec = R.readP_to_S . lisp

instance Show Lisp where
	show Null = "null"
	show (Bool b)
		| b = "true"
		| otherwise = "false"
	show (Symbol s) = s
	show (String s) = show s
	show (Number n) = either show show (floatingOrInteger n :: Either Double Integer)
	show (List vs) = "(" ++ unwords (map show vs) ++ ")"

instance ToJSON Lisp where
	toJSON Null = toJSON A.Null
	toJSON (Bool b) = toJSON b
	toJSON (Symbol s) = toJSON s
	toJSON (String s) = toJSON s
	toJSON (Number n) = toJSON n
	toJSON (List vs)
		| null keywords = toJSON $ map toJSON vals
		| null vals = keywordsObject
		| otherwise = toJSON $ map toJSON vals ++ [keywordsObject]
		where
			(vals, keywords) = partitionEithers $ unfoldr cutKeyword vs
			keywordsObject = A.object [fromString (dropColon k) .= v | (k, v) <- keywords]

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

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

instance FromJSON Lisp where
	parseJSON A.Null = return Null
	parseJSON (A.Bool b) = return $ Bool b
	parseJSON (A.String s) = return $ String $ T.unpack s
	parseJSON (A.Number n) = return $ Number n
	parseJSON (A.Array vs) = fmap List $ mapM parseJSON $ V.toList vs
	parseJSON (A.Object obj) = fmap (List . concat) $ mapM (\(k, v) -> sequence [pure $ Symbol (':' : T.unpack k), parseJSON v]) $ HM.toList obj

decodeLisp :: FromJSON a => ByteString -> Either P.String a
decodeLisp str = do
	sexp <- maybe (Left "Not a s-exp") Right . readMaybe . LT.unpack . LT.decodeUtf8 $ str
	parseEither parseJSON $ toJSON (sexp :: Lisp)

encodeLisp :: ToJSON a => a -> ByteString
encodeLisp r = LT.encodeUtf8 . LT.pack $ maybe
	"(:error \"can't convert to s-exp\")"
	(show :: Lisp -> P.String)
	(parseMaybe parseJSON (toJSON r))