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