module Data.AttoLisp
(
Lisp(..), nil, isNull,
FromLisp(..), Result(..), fromLisp,
Failure, Success, Parser,
parse, parseMaybe, parseEither, typeMismatch,
ToLisp(..),
mkStruct, struct,
encode, fromLispExpr,
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.Number (Number(..))
import Data.Data
import Data.Int ( Int8, Int16, Int32, Int64 )
import Data.List ( foldl' )
import Data.Ratio ( Ratio )
import Data.Monoid
import Data.String
import Data.Word ( Word, Word8, Word16, Word32, Word64 )
import Numeric (showHex)
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Char8 as AC
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
import qualified Data.Map as M
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
fromLisp :: FromLisp a => Lisp -> Result a
fromLisp = parse parseLisp
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 (IsFunction a f, ParseList' f a b) => ParseList a b where
parseList = parseList' (undefined :: f)
class ParseList' f a b | f a -> b where
parseList' :: f -> String -> a -> [Lisp] -> Parser b
instance (FromLisp a, IsFunction b f, ParseList' f b c, ParseList b c)
=> ParseList' HTrue (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' HFalse a a where
parseList' _ _msg r [] = return r
parseList' _ msg _ (_:_) = fail $ "Too many arguments for object: " ++ msg
data HTrue
data HFalse
class IsFunction a b | a -> b
instance TypeCast f HTrue => IsFunction (x -> y) f
instance TypeCast f HFalse => IsFunction a f
class TypeCast a b | a -> b, b -> a where
typeCast :: a -> b
class TypeCast' t a b | t a -> b, t b -> a where
typeCast' :: t -> a -> b
class TypeCast'' t a b | t a -> b, t b -> a where
typeCast'' :: t -> a -> b
instance TypeCast' () a b => TypeCast a b where
typeCast x = typeCast' () x
instance TypeCast'' t a b => TypeCast' t a b where
typeCast' = typeCast''
instance TypeCast'' () a a where
typeCast'' _ x = x
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 Lisp where
toLisp = id
instance FromLisp Lisp where
parseLisp = pure
instance ToLisp Bool where
toLisp b = if b then Symbol "t" else nil
instance FromLisp Bool where
parseLisp e = if isNull e then pure False else pure True
instance ToLisp Char where
toLisp c = String (T.singleton c)
instance FromLisp Char where
parseLisp (String t)
| T.compareLength t 1 == EQ = pure (T.head t)
parseLisp e = typeMismatch "String" 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
instance (ToLisp a, ToLisp b) => ToLisp (Either a b) where
toLisp (Left a) = toLisp a
toLisp (Right b) = toLisp b
instance (FromLisp a, FromLisp b) => FromLisp (Either a b) where
parseLisp e = Left <$> parseLisp e <|> Right <$> parseLisp e
instance ToLisp [Char] where
toLisp s = String (T.pack s)
instance FromLisp [Char] where
parseLisp (String t) = pure (T.unpack t)
parseLisp e = typeMismatch "String" e
instance ToLisp Double where
toLisp = Number . D
instance FromLisp Double where
parseLisp (Number n) =
case n of
D d -> pure d
I i -> pure (fromIntegral i)
parseLisp e | isNull e = pure (0/0)
parseLisp e = typeMismatch "Double" e
instance ToLisp Float where
toLisp = Number . fromRational . toRational
instance FromLisp Float where
parseLisp (Number n) =
case n of
D d -> pure (fromRational (toRational d))
I i -> pure (fromIntegral i)
parseLisp e | isNull e = pure (0/0)
parseLisp e = typeMismatch "Float" e
instance ToLisp Number where
toLisp = Number
instance FromLisp Number where
parseLisp (Number n) = pure n
parseLisp e | isNull e = pure (D (0/0))
parseLisp e = typeMismatch "Number" e
instance ToLisp (Ratio Integer) where
toLisp = Number . fromRational
instance FromLisp (Ratio Integer) where
parseLisp (Number n) =
case n of
D d -> pure (toRational d)
I i -> pure (fromIntegral i)
parseLisp e = typeMismatch "Ratio Integer" e
instance ToLisp Int8 where
toLisp = Number . fromIntegral
instance FromLisp Int8 where
parseLisp = parseIntegral
instance ToLisp Int16 where
toLisp = Number . fromIntegral
instance FromLisp Int16 where
parseLisp = parseIntegral
instance ToLisp Int32 where
toLisp = Number . fromIntegral
instance FromLisp Int32 where
parseLisp = parseIntegral
instance ToLisp Int64 where
toLisp = Number . fromIntegral
instance FromLisp Int64 where
parseLisp = parseIntegral
instance ToLisp Word where
toLisp = Number . fromIntegral
instance FromLisp Word where
parseLisp = parseIntegral
instance ToLisp Word8 where
toLisp = Number . fromIntegral
instance FromLisp Word8 where
parseLisp = parseIntegral
instance ToLisp Word16 where
toLisp = Number . fromIntegral
instance FromLisp Word16 where
parseLisp = parseIntegral
instance ToLisp Word32 where
toLisp = Number . fromIntegral
instance FromLisp Word32 where
parseLisp = parseIntegral
instance ToLisp Word64 where
toLisp = Number . fromIntegral
instance FromLisp Word64 where
parseLisp = parseIntegral
instance ToLisp a => ToLisp [a] where
toLisp l = List (map toLisp l)
instance FromLisp a => FromLisp [a] where
parseLisp (List l) = mapM parseLisp l
parseLisp e = typeMismatch "list" e
instance (ToLisp a, ToLisp b) => ToLisp (a, b) where
toLisp (a, b) = List [toLisp a, toLisp b]
instance (FromLisp a, FromLisp b) => FromLisp (a, b) where
parseLisp (List l) =
case l of
[a, b] -> (,) <$> parseLisp a <*> parseLisp b
_ -> fail $ "Cannot unpack list into a pair"
parseLisp (DotList hds b) =
case hds of
[a] -> (,) <$> parseLisp a <*> parseLisp b
_ -> fail $ "Cannot unpack dotted list into a pair"
parseLisp e = typeMismatch "pair" e
instance (ToLisp a, ToLisp b, ToLisp c) => ToLisp (a, b, c) where
toLisp (a, b, c) = List [toLisp a, toLisp b, toLisp c]
instance (FromLisp a, FromLisp b, FromLisp c) => FromLisp (a, b, c) where
parseLisp (List l) =
case l of
[a, b, c] -> (,,) <$> parseLisp a <*> parseLisp b <*> parseLisp c
_ -> fail $ "Cannot unpack list into a 3-tuple"
parseLisp e = typeMismatch "3-tuple" e
instance (ToLisp a, ToLisp b) => ToLisp (M.Map a b) where
toLisp mp = toLisp [ (toLisp k, toLisp v) | (k,v) <- M.toList mp ]
instance (Ord a, FromLisp a, FromLisp b) => FromLisp (M.Map a b) where
parseLisp e = M.fromList <$> parseLisp e
lisp :: A.Parser Lisp
lisp = skipLispSpace *>
(AC.char '(' *> list_ <|>
quoted <$> (AC.char '\'' *> AC.char '(' *> list_) <|>
String <$> (AC.char '"' *> lstring_) <|>
atom)
where
quoted l = List [Symbol "quote", l]
atom :: A.Parser Lisp
atom = number <|> symbol
number :: A.Parser Lisp
number = do
sym <- AC.takeWhile1 (not . terminatingChar)
case A.parseOnly AC.number sym of
Left _ -> fail "Not a number"
Right n -> return (Number n)
symbol :: A.Parser Lisp
symbol = Symbol <$> sym
where
sym = suffix
<|> do { p1 <- part; AC.option p1 (T.append p1 <$> suffix) }
suffix = T.append <$> psep <*> part
psep = do
c <- AC.char ':'
c2 <- AC.option [] (pure <$> AC.char ':')
pure $ T.pack (c:c2)
part = multiEscPart <|> basicPart
multiEscPart :: A.Parser T.Text
multiEscPart = do
vb <- AC.char8 '|'
(T.decodeUtf8 . B.cons vb) <$> chunk
where
stop c = c == backslash || c == verticalBar
chunk = do
p1 <- A.takeWhile (not . stop)
p2 <- AC.take 1
case p2 of
"|" -> return (p1 `B.append` p2)
"\\" -> do { p3 <- AC.take 1
; B.append (p1 `B.append` p2 `B.append` p3) <$> chunk
}
_ -> error "Data.AttoLisp: should be impossible to have gotten something other than '\\' or | here"
basicPart :: A.Parser T.Text
basicPart = do
sym <- AC.takeWhile1 (not . stop)
let !lst = B.last sym
if isSingleEsc lst
then
(decodeSym . B.append sym) <$> chunk
else
pure (decodeSym sym)
where
stop c = terminatingChar c || c == '|' || c == ':'
isSingleEsc w = w == backslash
chunk = do
escapee <- A.take 1
done <- AC.atEnd
if done then pure escapee else do
rest <- AC.takeWhile1 (not . terminatingChar)
let !lst = B.last rest
!pref = escapee `B.append` rest
if lst == backslash
then B.append pref <$> chunk
else pure pref
decodeSym = T.decodeUtf8
terminatingChar :: Char -> Bool
terminatingChar c =
c == ',' || c == '(' || c == ')' || c == '\'' || c == ';' || c == '`' || AC.isSpace c
list_ :: A.Parser Lisp
list_ = do
skipLispSpace
elems <- (lisp `AC.sepBy` skipLispSpace) <* skipLispSpace <* AC.char ')'
return (List elems)
doubleQuote :: Word8
doubleQuote = 34
backslash :: Word8
backslash = 92
verticalBar :: Word8
verticalBar = 124
skipLispSpace :: A.Parser ()
skipLispSpace =
AC.skipSpace >> many (comment >> AC.skipSpace) >> return ()
comment :: A.Parser ()
comment = do
_ <- AC.char ';' >> many (AC.notChar '\n')
end <- AC.atEnd
if end then AC.char '\n' >> return () else return ()
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"
fromLispExpr :: Lisp -> Blaze.Builder
fromLispExpr (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) ""
fromLispExpr (Symbol t) = Blaze.fromText t
fromLispExpr (Number n) = fromNumber n
fromLispExpr (List []) = Blaze.fromByteString "nil"
fromLispExpr (List l) = enc_list l (fromChar ')')
fromLispExpr (DotList l t) =
enc_list l (Blaze.fromByteString " . " `mappend` fromLispExpr t `mappend` fromChar ')')
enc_list :: [Lisp] -> Blaze.Builder -> Blaze.Builder
enc_list [] tl = fromChar '(' `mappend` tl
enc_list (x:xs) tl = fromChar '(' `mappend` fromLispExpr x `mappend` foldr f tl xs
where f e t = fromChar ' ' `mappend` fromLispExpr 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 . fromLispExpr . toLisp