module Data.AttoLisp
(
Lisp(..), nil, isNull,
FromLisp(..), Result(..),
Failure, Success, Parser,
parse, parseMaybe, parseEither, typeMismatch,
ToLisp(..),
mkStruct, struct,
encode, fromLisp,
lisp, atom,
)
where
import Blaze.ByteString.Builder.Char.Utf8 (fromChar)
import Blaze.ByteString.Builder.Word (fromWord8)
import Blaze.Text (double, integral)
import Control.Applicative
import Control.DeepSeq (NFData(..))
import Control.Monad
import Data.Attoparsec.Char8 hiding ( Parser, Result, parse, string, double )
import Data.Data
import Data.List ( foldl' )
import Data.Monoid
import Data.String
import Data.Word ( Word8 )
import Numeric (showHex)
import qualified Data.Attoparsec as A
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Attoparsec.Zepto as Z
import qualified Blaze.ByteString.Builder as Blaze
import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
data Lisp
= Symbol T.Text
| String T.Text
| Number Number
| List [Lisp]
| DotList [Lisp] Lisp
deriving (Eq, Ord, Data, Typeable)
instance Show Lisp where
showsPrec _ (Symbol a) = showString (T.unpack a)
showsPrec _ (String t) = shows (T.unpack t)
showsPrec _ (Number n) = shows n
showsPrec _ (List l) = showParen True (spaceSep l)
showsPrec _ (DotList l d) =
showParen True (spaceSep l . showString " . " . shows d)
spaceSep :: Show a => [a] -> ShowS
spaceSep [] = id
spaceSep (l1:ls1) = shows l1 . go1 ls1
where
go1 [] = id
go1 (l:ls) = showChar ' ' . shows l . go1 ls
instance IsString Lisp where
fromString s = String (fromString s)
instance NFData Lisp where
rnf (Symbol t) = rnf t
rnf (String t) = rnf t
rnf (Number r) = rnf r
rnf (List l) = foldl' (\x y -> rnf y `seq` x) () l
rnf (DotList l n) = foldl' (\x y -> rnf y `seq` x) () l `seq` rnf n
isNull :: Lisp -> Bool
isNull (List []) = True
isNull (Symbol "nil") = True
isNull _ = False
nil :: Lisp
nil = List []
type Failure f r = String -> f r
type Success a f r = a -> f r
newtype Parser a = Parser
{ runParser :: forall f r.
Failure f r
-> Success a f r
-> f r
}
instance Monad Parser where
m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks
in runParser m kf ks'
return a = Parser $ \_kf ks -> ks a
fail msg = Parser $ \kf _ks -> kf msg
instance Functor Parser where
fmap f m = Parser $ \kf ks -> let ks' a = ks (f a)
in runParser m kf ks'
instance Applicative Parser where
pure = return
(<*>) = apP
instance Alternative Parser where
empty = fail "empty"
(<|>) = mplus
instance MonadPlus Parser where
mzero = fail "mzero"
mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks
in runParser a kf' ks
instance Monoid (Parser a) where
mempty = fail "mempty"
mappend = mplus
apP :: Parser (a -> b) -> Parser a -> Parser b
apP d e = do
b <- d
a <- e
return (b a)
data Result a = Error String
| Success a
deriving (Eq, Show, Typeable)
instance (NFData a) => NFData (Result a) where
rnf (Success a) = rnf a
rnf (Error err) = rnf err
instance Functor Result where
fmap f (Success a) = Success (f a)
fmap _ (Error err) = Error err
instance Monad Result where
return = Success
Success a >>= k = k a
Error err >>= _ = Error err
instance Applicative Result where
pure = return
(<*>) = ap
instance MonadPlus Result where
mzero = fail "mzero"
mplus a@(Success _) _ = a
mplus _ b = b
instance Alternative Result where
empty = mzero
(<|>) = mplus
instance Monoid (Result a) where
mempty = fail "mempty"
mappend = mplus
parse :: (a -> Parser b) -> a -> Result b
parse m v = runParser (m v) Error Success
parseMaybe :: (a -> Parser b) -> a -> Maybe b
parseMaybe m v = runParser (m v) (const Nothing) Just
parseEither :: (a -> Parser b) -> a -> Either String b
parseEither m v = runParser (m v) Left Right
mkStruct :: T.Text -> [Lisp] -> Lisp
mkStruct name fields = List (Symbol name : fields)
class ToLisp a where
toLisp :: a -> Lisp
class FromLisp a where
parseLisp :: Lisp -> Parser a
parseIntegral :: Integral a => Lisp -> Parser a
parseIntegral (Number n) = pure (floor n)
parseIntegral v = typeMismatch "Integral" v
typeMismatch :: String
-> Lisp
-> Parser a
typeMismatch expected actual =
fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
" instead"
where
name = case actual of
Symbol _ -> "symbol"
List [] -> "nil"
List (Symbol s:_) -> T.unpack s ++ " object"
List _ -> "list"
DotList _ _ -> "list"
String _ -> "string"
Number _ -> "number"
class ParseList a b | a -> b where
parseList :: String -> a -> [Lisp] -> Parser b
instance (FromLisp a, ParseList b c) => ParseList (a -> b) c where
parseList msg _ [] = fail $ "Too few arguments for object: " ++ msg
parseList msg f (x:xs) = do
y <- parseLisp x
parseList msg (f y) xs
instance ParseList a a where
parseList _msg r [] = return r
parseList msg _ (_:_) = fail $ "Too many arguments for object: " ++ msg
struct :: ParseList f a => T.Text -> f -> Lisp -> Parser a
struct tag f (List (Symbol t:rest)) | t == tag =
parseList (T.unpack tag) f rest
struct tag _ e = typeMismatch (T.unpack tag ++ " object") e
instance ToLisp Integer where
toLisp n = Number (fromInteger n)
instance FromLisp Integer where
parseLisp = parseIntegral
instance ToLisp Int where
toLisp n = Number (fromIntegral n)
instance FromLisp Int where
parseLisp = parseIntegral
instance ToLisp T.Text where
toLisp = String
instance FromLisp T.Text where
parseLisp (String t) = pure t
parseLisp e = typeMismatch "Text" e
instance ToLisp () where
toLisp () = List []
instance FromLisp () where
parseLisp e | isNull e = pure ()
| otherwise = typeMismatch "()" e
instance ToLisp a => ToLisp (Maybe a) where
toLisp Nothing = nil
toLisp (Just a) = toLisp a
instance FromLisp a => FromLisp (Maybe a) where
parseLisp e | isNull e = pure Nothing
parseLisp e = Just <$> parseLisp e
lisp :: A.Parser Lisp
lisp = skipSpace *>
(char '(' *> list_ <|>
String <$> (char '"' *> lstring_) <|>
atom)
atom :: A.Parser Lisp
atom = do
sym <- takeWhile1 (\c -> not (terminatingChar c))
let !w = B.unsafeIndex sym 0
if (w >= 48 && w <= 57) ||
w == 43 || w == 45
then do
case A.parseOnly number sym of
Left _ -> pure (Symbol (T.decodeUtf8 sym))
Right n -> pure (Number n)
else
pure (Symbol (T.decodeUtf8 sym))
terminatingChar :: Char -> Bool
terminatingChar c =
c == ',' || c == '(' || c == ')' || c == '\'' || c == ';' || c == '`' || isSpace c
list_ :: A.Parser Lisp
list_ = do
skipSpace
elems <- (lisp `sepBy` skipSpace) <* char ')'
return (List elems)
doubleQuote :: Word8
doubleQuote = 34
backslash :: Word8
backslash = 92
lstring_ :: A.Parser T.Text
lstring_ = do
s <- A.scan False $ \s c -> if s then Just False
else if c == doubleQuote
then Nothing
else Just (c == backslash)
_ <- A.word8 doubleQuote
if backslash `B.elem` s
then case Z.parse unescapeString s of
Right r -> return (T.decodeUtf8 r)
Left err -> fail err
else return (T.decodeUtf8 s)
unescapeString :: Z.Parser B.ByteString
unescapeString = Blaze.toByteString <$> go mempty where
go acc = do
h <- Z.takeWhile (/=backslash)
let rest = do
start <- Z.take 2
let !slash = B.unsafeHead start
!t = B.unsafeIndex start 1
escape = case B.findIndex (==t) "\"\\/ntbrfu" of
Just i -> i
_ -> 255
if slash /= backslash || escape == 255
then fail "invalid JSON escape sequence"
else do
let cont m = go (acc `mappend` Blaze.fromByteString h `mappend` m)
cont (fromWord8 (B.unsafeIndex mapping escape))
done <- Z.atEnd
if done
then return (acc `mappend` Blaze.fromByteString h)
else rest
mapping = "\"\\/\n\t\b\r\f"
fromLisp :: Lisp -> Blaze.Builder
fromLisp (String str) = string str
where
string s = fromChar '"' `mappend` quote s `mappend` fromChar '"'
quote q =
let (h, t) = T.break isEscape q in
case T.uncons t of
Just (c,t') -> Blaze.fromText h `mappend` escape c `mappend` quote t'
Nothing -> Blaze.fromText h
isEscape c = c == '"' || c == '\\' || c < '\x20'
escape '\"' = Blaze.fromByteString "\\\""
escape '\\' = Blaze.fromByteString "\\\\"
escape '\n' = Blaze.fromByteString "\\n"
escape '\r' = Blaze.fromByteString "\\r"
escape '\t' = Blaze.fromByteString "\\t"
escape c
| c < '\x20' = Blaze.fromString $ "\\x" ++ replicate (2 length h) '0' ++ h
| otherwise = fromChar c
where h = showHex (fromEnum c) ""
fromLisp (Symbol t) = Blaze.fromText t
fromLisp (Number n) = fromNumber n
fromLisp (List []) = Blaze.fromByteString "nil"
fromLisp (List l) = enc_list l (fromChar ')')
fromLisp (DotList l t) =
enc_list l (Blaze.fromByteString " . " `mappend` fromLisp t `mappend` fromChar ')')
enc_list :: [Lisp] -> Blaze.Builder -> Blaze.Builder
enc_list [] tl = fromChar '(' `mappend` tl
enc_list (x:xs) tl = fromChar '(' `mappend` fromLisp x `mappend` foldr f tl xs
where f e t = fromChar ' ' `mappend` fromLisp e `mappend` t
fromNumber :: Number -> Blaze.Builder
fromNumber (I i) = integral i
fromNumber (D d) = double d
encode :: ToLisp a => a -> Lazy.ByteString
encode = Blaze.toLazyByteString . fromLisp . toLisp