{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module What4.Protocol.SExp
( SExp(..)
, parseSExp
, parseSExpBody
, stringToSExp
, parseNextWord
, asAtomList
, asNegAtomList
, skipSpaceOrNewline
, sExpToString
) where
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail( MonadFail )
#endif
import Control.Applicative
import Control.Monad (msum)
import Data.Attoparsec.Text
import Data.Char
import Data.Monoid
import Data.String
import Data.Text (Text)
import qualified Data.Text as Text
import Prelude hiding (takeWhile)
skipSpaceOrNewline :: Parser ()
skipSpaceOrNewline :: Parser ()
skipSpaceOrNewline = (Char -> Bool) -> Parser ()
skipWhile Char -> Bool
f
where f :: Char -> Bool
f Char
c = Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\n'
parseNextWord :: Parser Text
parseNextWord :: Parser Text Text
parseNextWord = do
Parser ()
skipSpaceOrNewline
forall a. Monoid a => a -> a -> a
mappend ((Char -> Bool) -> Parser Text Text
takeWhile1 Char -> Bool
isAlphaNum) (forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Unexpected end of stream.")
data SExp = SAtom Text
| SString Text
| SApp [SExp]
deriving (SExp -> SExp -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SExp -> SExp -> Bool
$c/= :: SExp -> SExp -> Bool
== :: SExp -> SExp -> Bool
$c== :: SExp -> SExp -> Bool
Eq, Eq SExp
SExp -> SExp -> Bool
SExp -> SExp -> Ordering
SExp -> SExp -> SExp
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SExp -> SExp -> SExp
$cmin :: SExp -> SExp -> SExp
max :: SExp -> SExp -> SExp
$cmax :: SExp -> SExp -> SExp
>= :: SExp -> SExp -> Bool
$c>= :: SExp -> SExp -> Bool
> :: SExp -> SExp -> Bool
$c> :: SExp -> SExp -> Bool
<= :: SExp -> SExp -> Bool
$c<= :: SExp -> SExp -> Bool
< :: SExp -> SExp -> Bool
$c< :: SExp -> SExp -> Bool
compare :: SExp -> SExp -> Ordering
$ccompare :: SExp -> SExp -> Ordering
Ord, Int -> SExp -> ShowS
[SExp] -> ShowS
SExp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SExp] -> ShowS
$cshowList :: [SExp] -> ShowS
show :: SExp -> String
$cshow :: SExp -> String
showsPrec :: Int -> SExp -> ShowS
$cshowsPrec :: Int -> SExp -> ShowS
Show)
instance IsString SExp where
fromString :: String -> SExp
fromString = Text -> SExp
SAtom forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
isTokenChar :: Char -> Bool
isTokenChar :: Char -> Bool
isTokenChar Char
'(' = Bool
False
isTokenChar Char
')' = Bool
False
isTokenChar Char
'"' = Bool
False
isTokenChar Char
c = Bool -> Bool
not (Char -> Bool
isSpace Char
c)
readToken :: Parser Text
readToken :: Parser Text Text
readToken = (Char -> Bool) -> Parser Text Text
takeWhile1 Char -> Bool
isTokenChar
parseSExp ::
Parser Text ->
Parser SExp
parseSExp :: Parser Text Text -> Parser SExp
parseSExp Parser Text Text
readString = do
Parser ()
skipSpaceOrNewline
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ Char -> Parser Char
char Char
'(' forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> Parser Text Text -> Parser SExp
parseSExpBody Parser Text Text
readString
, Text -> SExp
SString forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
readString
, Text -> SExp
SAtom forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
readToken
]
parseSExpBody ::
Parser Text ->
Parser SExp
parseSExpBody :: Parser Text Text -> Parser SExp
parseSExpBody Parser Text Text
readString =
Parser ()
skipSpaceOrNewline forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> ([SExp] -> SExp
SApp forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: Type -> Type) a. Alternative f => f a -> f [a]
many (Parser Text Text -> Parser SExp
parseSExp Parser Text Text
readString)) forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaceOrNewline forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
')'
stringToSExp :: MonadFail m =>
Parser Text ->
String ->
m [SExp]
stringToSExp :: forall (m :: Type -> Type).
MonadFail m =>
Parser Text Text -> String -> m [SExp]
stringToSExp Parser Text Text
readString String
s = do
let parseSExpList :: Parser Text [SExp]
parseSExpList = forall (f :: Type -> Type) a. Alternative f => f a -> f [a]
many (Parser Text Text -> Parser SExp
parseSExp Parser Text Text
readString) forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput
case forall a. Parser a -> Text -> Either String a
parseOnly Parser Text [SExp]
parseSExpList (String -> Text
Text.pack String
s) of
Left String
e -> forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"stringToSExpr error: " forall a. [a] -> [a] -> [a]
++ String
e
Right [SExp]
v -> forall (m :: Type -> Type) a. Monad m => a -> m a
return [SExp]
v
asNegAtomList :: SExp -> Maybe [(Bool,Text)]
asNegAtomList :: SExp -> Maybe [(Bool, Text)]
asNegAtomList (SApp [SExp]
xs) = [SExp] -> Maybe [(Bool, Text)]
go [SExp]
xs
where
go :: [SExp] -> Maybe [(Bool, Text)]
go [] = forall a. a -> Maybe a
Just []
go (SAtom Text
a : [SExp]
ys) = ((Bool
True,Text
a)forall a. a -> [a] -> [a]
:) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [SExp] -> Maybe [(Bool, Text)]
go [SExp]
ys
go (SApp [SAtom Text
"not", SAtom Text
a] : [SExp]
ys) = ((Bool
False,Text
a)forall a. a -> [a] -> [a]
:) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [SExp] -> Maybe [(Bool, Text)]
go [SExp]
ys
go [SExp]
_ = forall a. Maybe a
Nothing
asNegAtomList SExp
_ = forall a. Maybe a
Nothing
asAtomList :: SExp -> Maybe [Text]
asAtomList :: SExp -> Maybe [Text]
asAtomList (SApp [SExp]
xs) = [SExp] -> Maybe [Text]
go [SExp]
xs
where
go :: [SExp] -> Maybe [Text]
go [] = forall a. a -> Maybe a
Just []
go (SAtom Text
a:[SExp]
ys) = (Text
aforall a. a -> [a] -> [a]
:) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [SExp] -> Maybe [Text]
go [SExp]
ys
go [SExp]
_ = forall a. Maybe a
Nothing
asAtomList SExp
_ = forall a. Maybe a
Nothing
sExpToString :: SExp -> String
sExpToString :: SExp -> String
sExpToString (SAtom Text
t) = Text -> String
Text.unpack Text
t
sExpToString (SString Text
t) = (Char
'"' forall a. a -> [a] -> [a]
: Text -> String
Text.unpack Text
t) forall a. [a] -> [a] -> [a]
++ [Char
'"']
sExpToString (SApp [SExp]
ss) = (Char
'(' forall a. a -> [a] -> [a]
: [String] -> String
Data.String.unwords (forall a b. (a -> b) -> [a] -> [b]
map SExp -> String
sExpToString [SExp]
ss)) forall a. [a] -> [a] -> [a]
++ [Char
')']