There are a number of questions on this site about s-expression parsing: e.g., Calculator parsing S-expressions and Code from "Write Yourself a Scheme in 48 Hours" tutorial.
However, these don't parse quasiquote, and quasiquote is amazing!
So I wanted to parse quasiquote.
Making the simplification that s-expressions are not allowed to have symbols starting with ,, I can say that "all s-expressions are quasiquoted expressions without any unquotes or unquote-splicings." I used this idea as the basis for the implementation: parse quasiquoted expressions, then expand them to s-expressions if desired.
I also limited the numbers to decimal integer literals, for simplicity. I don't think it would be particularly difficult to expand this to all of, e.g., R5RS's numeric literal types.
Some questions:
- Does the general strategy (
QExptoSExp) seem reasonable? - I chose to make all the unquote and unquote-splicing expressions be normal s-expressions already (i.e., not themselves quasiquoted) to ensure termination. Does this sound reasonable?
- Does the relationship
between
expandQuasiquoteandresolveQuasiquoteseem reasonable? In particular, is there a different approach that would prevent (with a compile-time guarantee) the invariant violation listed in theRight _ -> Leftblock ofresolveQuasiquote? - I've heard people advocate not using
try, or at least using it sparingly. Do my uses seem reasonable? - Is there a better way to handle
the problem that I introduced
castErrorto solve? - Any suggestions regarding monad usage?
- Any suggestions for better parse error handling?
Anything else?
For reference, the grammar I'm using is (roughly):
SExp = number
| id
| ( SExp ... )
number = nonzero-digit digit ...
| + digit ...
| - digit ...
nonzero-digit = 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
digit = 0 | nonzero-digit
id matches [^0-9+-,\s][^\s,]*
QExp = number
| id
| ( QLExp ... )
QLExp = QExp
| ,id
| , id
| ,@id
| ,@ id
where ( τ ), [ τ ] and { τ } are all interchangeable (à la Racket).
So here's the implementation!
src/SExp.hs
-- Representation of s-expressions as an ADT,
-- along with a parser for them.
-- Includes support for quasiquoting.
module SExp ( SExp(..)
, QExp(..)
, parseSexp
, parseQexp
, parseQexpRaw
, resolveQuasiquote
) where
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Number as PNumber
import Control.Monad
import Data.Char (isSpace)
--------------------------------------------------------------
-- Data definitions
--------------------------------------------------------------
data SExp = Symbol String
| Number Int
| List [SExp]
deriving (Show, Eq)
data QExp = QSymbol String
| QNumber Int
| QList [QExp]
| QUnquote UnquoteIdentifier
| QSplice UnquoteIdentifier
deriving (Show, Eq)
-- When converting a quasiquoted expression to an s-expression,
-- we need to substitute in existing s-expressions
-- at every QUnquote and QSplice.
-- In the concrete syntax, these are specified by name,
-- and then we look them up in a user-provided table;
-- each such name is an UnquoteIdentifier.
type UnquoteIdentifier = String
type UnquoteBindings = [(UnquoteIdentifier, SExp)]
type SplicingBindings = [(UnquoteIdentifier, [SExp])]
type QuasiquoteBindings = (UnquoteBindings, SplicingBindings)
--------------------------------------------------------------
-- Constants and useful parser combinators
--------------------------------------------------------------
-- Signals the beginning of a QUnquote or QSplice.
unquoteToken :: Char
unquoteToken = ','
-- Signals the beginning of a QSplice
-- when immediately following the unquoteToken.
splicingToken :: Char
splicingToken = '@'
-- Pairs of opening and closing delimiters
-- that can all be synonymously used for lists.
delimiters :: [(Char, Char)]
delimiters = zip "([{" ")]}"
-- A list of all delimiters
-- (useful for exclusion from the set of valid identifier characters, e.g.).
flatDelimiters :: [Char]
flatDelimiters = (uncurry (++) . unzip) delimiters
-- Match any character except for a space or one of the given characters.
exceptSpaceOr :: [Char] -> GenParser Char () Char
exceptSpaceOr xs = satisfy (\x -> not $ isSpace x || x `elem` xs)
-- Match a parser, then another parser, then discard the second.
followedBy :: Monad m => m a -> m b -> m a
followedBy x y = x >>= \result -> y >> return result
--------------------------------------------------------------
-- Converting quasiquoted expressions to s-expressions
--------------------------------------------------------------
-- Expand a quasiquoted expression into zero or more s-expressions.
-- This is needed as a layer of indirection
-- because QSplice (unquote-splicing) terms
-- can contain any number of values.
expandQuasiquote :: QuasiquoteBindings -> QExp -> Either String [SExp]
expandQuasiquote _ (QSymbol s) = Right $ [Symbol s]
expandQuasiquote _ (QNumber n) = Right $ [Number n]
expandQuasiquote bs (QList xs) = do
subresults <- mapM (expandQuasiquote bs) xs
let listItems = concat subresults
return [List listItems]
expandQuasiquote (ub, _) (QUnquote id) = case lookup id ub of
Just sexp -> Right [sexp]
Nothing -> Left $ "unbound unquote by the name of: `" ++ id ++ "'"
expandQuasiquote (_, sb) (QSplice id) = case lookup id sb of
Just sexps -> Right sexps
Nothing -> Left $ "unbound unquote-splicing by the name of: `" ++ id ++ "'"
resolveQuasiquote :: QuasiquoteBindings -> QExp -> Either String SExp
resolveQuasiquote _ (QSplice _) = Left $
"unquote-splicing is only allowed within a list, not at the top level"
resolveQuasiquote bs qexp = case expandQuasiquote bs qexp of
Left err -> Left err
Right [single] -> Right single
Right _ -> Left "invariant violation: expected a single expanded SExp"
--------------------------------------------------------------
-- Parsers for quasiquoted expressions
--------------------------------------------------------------
-- A list, delimited by parentheses, brackets, or braces,
-- and containing zero or more sub-expressions.
listExpr :: GenParser Char () QExp
listExpr = foldl1 (<|>) $ flip map delimiters $
\(open, close) -> between (char open) (char close) (liftM QList qexprs)
-- Zero or more expressions, separated and bordered by arbitrary spaces.
qexprs :: GenParser Char () [QExp]
qexprs = do
-- We need these `spaces` even though expressions trim their own spaces
-- to account for the case where the list is empty but contains spaces.
-- (We don't want to try to parse an expression just because we see a space.)
spaces
item <- optionMaybe qexp
case item of
Just x -> liftM (x:) qexprs
Nothing -> return []
-- A symbol, containing any non-whitespace characters (not necessarily ASCII)
-- and not starting with a digit or unquote token.
symbolExpr :: GenParser Char () QExp
symbolExpr = liftM QSymbol $ liftM2 (:) initial (many internal)
where nonWordChars = unquoteToken:flatDelimiters
digits = ['0'..'9']
initial = exceptSpaceOr $ nonWordChars ++ digits
internal = exceptSpaceOr nonWordChars
-- Either an unquote-splicing or unquote expression.
unquoteExpr :: GenParser Char () QExp
unquoteExpr = char unquoteToken >> (splicing <|> unquote)
--
-- note: splicing has to come first so that we parse, e.g., ",@x"
-- as QSplice "x" and not QUnquote "@x"
where splicing = char splicingToken >> spaces >> liftM QSplice name
unquote = spaces >> liftM QUnquote name
name = many1 $ exceptSpaceOr $ unquoteToken:flatDelimiters
-- A positive or negative integer literal.
numberExpr :: GenParser Char () QExp
numberExpr = liftM QNumber PNumber.int
-- An arbitrary quasiquoted expression.
qexp :: GenParser Char () QExp
qexp = spaces >>
(try unquoteExpr
<|> listExpr
<|> try numberExpr
<|> symbolExpr) `followedBy` spaces
-- The top-level quasiquoted expression,
-- which must be terminated by the end of input.
topExpr :: GenParser Char () QExp
topExpr = qexp `followedBy` eof
--------------------------------------------------------------
-- The public interface
--------------------------------------------------------------
-- Unfortunately, the parse errors have different types from our errors,
-- so we lose a bit of context if it's a ParseError
-- (we only get the message, not the type).
castError :: Either ParseError a -> Either String a
castError (Right result) = Right result
castError (Left pe) = Left $ show pe
-- Parse a given string to a quasiquoted expression,
-- or return a parse error message.
parseQexpRaw :: String -> Either String QExp
parseQexpRaw = castError . parse topExpr ""
-- Parse a given string to a quasiquoted expression,
-- then resolve it to an s-expression.
-- If either step fails, yield an error message.
--
parseQexp :: QuasiquoteBindings -> String -> Either String SExp
parseQexp bindings input = parseQexpRaw input >>= resolveQuasiquote bindings
-- Parse a given string to an s-expression.
-- If the string contains quasiquoted parts, it will throw an error.
parseSexp :: String -> Either String SExp
parseSexp input = case parseQexpRaw input of
Right qexp -> case resolveQuasiquote ([], []) qexp of
Right sexp -> Right sexp
Left err -> Left $ concat $
[ "detected use of quasiquote in s-expression; "
, "did you mean to use parseQexp and provide bindings? "
, "(original error: "
, err
, ")"
]
Left err -> Left $ err
test/SExpSpec.hs
module SExpSpec(spec) where
import Test.Hspec
import SExp
import Control.Monad
spec :: Spec
spec = do
parseSexpSpec
parseQExpRawSpec
resolveQuasiquoteSpec
quasiquoteErrorHandlingSpec
parseSexpSpec :: Spec
parseSexpSpec = describe "parseSexp" $ do
describe "for symbols" specSymbols
describe "for numbers" specNumbers
describe "for lists" specLists
describe "regarding spaces" specSpaces
it "should parse a somewhat complicated expression" $
"{abc 123 -345 (b {} 12) zyxwvut}" `shouldParseTo`
List [ Symbol "abc"
, Number 123
, Number (-345)
, List [ Symbol "b"
, List []
, Number 12
]
, Symbol "zyxwvut"
]
specSymbols :: Spec
specSymbols = do
it "should parse alphabetic symbols" $
"abc" `shouldParseTo` Symbol "abc"
it "should parse alphanumeric symbols" $
"a113" `shouldParseTo` Symbol "a113"
it "should parse symbols with alphanumeric and special characters" $
"secret:a-113" `shouldParseTo` Symbol "secret:a-113"
it "should parse non-ASCII characters" $
"β-carotene" `shouldParseTo` Symbol "β-carotene"
it "should reject symbols with initial digits" $
shouldFailToParse "113-a"
specNumbers :: Spec
specNumbers = do
it "should parse positive numbers" $
"123" `shouldParseTo` Number 123
it "should parse zero" $
"0" `shouldParseTo` Number 0
it "should parse negative numbers" $
"-123" `shouldParseTo` Number (-123)
it "should parse (+ 1 2) as a list, not (fail to parse as) a number" $
"(+ 1 2)" `shouldParseTo` List [Symbol "+", Number 1, Number 2]
specLists :: Spec
specLists = do
forM_ [ ("parentheses", "(1 2 3)")
, ("brackets", "[1 2 3]")
, ("braces", "{1 2 3}")
] $
\(kind, input) ->
it ("should parse lists with " ++ kind) $
input `shouldParseTo` (List $ map Number [1..3])
it "should parse heterogeneous lists" $
"(hal 9000)" `shouldParseTo` List [ Symbol "hal", Number 9000 ]
it "should parse nested lists with the same delimiter" $
"(1 2 (3 4))" `shouldParseTo`
List [ Number 1, Number 2, List [ Number 3, Number 4 ] ]
it "should parse nested lists with different delimiters" $
"(1 2 [3 4])" `shouldParseTo`
List [ Number 1, Number 2, List [ Number 3, Number 4 ] ]
it "should reject nested lists with mismatched delimiters" $
shouldFailToParse "(1 2 [3 4)]"
it "should parse the empty list" $
"()" `shouldParseTo` List []
it "should parse the empty list with spaces" $
"{ }" `shouldParseTo` List []
it "should reject an unterminated list" $
shouldFailToParse "("
it "should reject a closing delimiter with no open delimiter" $
shouldFailToParse ")"
specSpaces :: Spec
specSpaces = do
it "should parse a list with trailing internal spaces" $
"(1 )" `shouldParseTo` List [Number 1]
it "should parse a list with leading internal spaces" $
"( 1)" `shouldParseTo` List [Number 1]
it "should parse a list with both leading and trailing internal spaces" $
"( 1 )" `shouldParseTo` List [Number 1]
it "should parse a list with both leading and trailing internal spaces" $
" ( 1 ) " `shouldParseTo` List [Number 1]
it "should parse a symbol with both leading and trailing spaces" $
" abc " `shouldParseTo` Symbol "abc"
it "should parse a number with both leading and trailing spaces" $
" 37 " `shouldParseTo` Number 37
parseQExpRawSpec :: Spec
parseQExpRawSpec = describe "parseQexpRaw" $ do
describe "should parse normal s-expressions" $ do
-- We're a bit light on the testing here
-- because we assume that the implementation delegates to
-- the already-tested s-expression parser
-- (or, rather, that the s-expression parser
-- is actually based on the quasiquote parser).
it "like a number" $
"10" `shouldQParseTo` QNumber 10
it "like a symbol" $
"bob" `shouldQParseTo` QSymbol "bob"
it "like a list" $
"(1 {two} 33)"
`shouldQParseTo`
QList [ QNumber 1
, QList [ QSymbol "two" ]
, QNumber 33
]
parseQExpRawUnquoteSpec
parseQExpRawSpliceSpec
parseQExpRawUnquoteSpec :: Spec
parseQExpRawUnquoteSpec = describe "should parse unquotes" $ do
it "at the top level" $
",x" `shouldQParseTo` QUnquote "x"
it "at the top level, with a space after the comma" $
", y" `shouldQParseTo` QUnquote "y"
describe "inside a list" $ do
it "inside a list" $
"(a ,thing z)"
`shouldQParseTo`
QList [ QSymbol "a", QUnquote "thing", QSymbol "z" ]
it "with a space after the comma" $
"(a , thing z)"
`shouldQParseTo`
QList [ QSymbol "a", QUnquote "thing", QSymbol "z" ]
it "with multiple consecutively" $
"(,a ,b ,c)"
`shouldQParseTo`
QList (map QUnquote ["a", "b", "c"])
describe "with no preceding space" $ do
it "when following a symbol" $
"(a,b c)"
`shouldQParseTo`
QList [ QSymbol "a", QUnquote "b", QSymbol "c" ]
it "when following a number" $
"(1,b c)"
`shouldQParseTo`
QList [ QNumber 1, QUnquote "b", QSymbol "c" ]
it "when following another unquote" $
"(,a,b,c)"
`shouldQParseTo`
QList (map QUnquote ["a", "b", "c"])
parseQExpRawSpliceSpec :: Spec
parseQExpRawSpliceSpec = describe "should parse unquote-splicings" $ do
it "within a list" $ do
"(thing1 ,@more-things thingN)"
`shouldQParseTo`
QList [ QSymbol "thing1"
, QSplice "more-things"
, QSymbol "thingN"
]
it "with a space after the \",@\"" $
",@ thing" `shouldQParseTo` QSplice "thing"
it "with multiple consecutively" $
"(,@a ,@b ,@c)"
`shouldQParseTo`
QList (map QSplice ["a", "b", "c"])
describe "with no preceding space" $ do
it "when following a symbol" $
"(a,@b c)"
`shouldQParseTo`
QList [ QSymbol "a", QSplice "b", QSymbol "c" ]
it "when following a number" $
"(1,@b c)"
`shouldQParseTo`
QList [ QNumber 1, QSplice "b", QSymbol "c" ]
it "when following another unquote-splicing" $
"(,@a,@b,@c)"
`shouldQParseTo`
QList (map QSplice ["a", "b", "c"])
it "when interspersed with normal unquotes" $
"(,@a,b,@c,d,@e)"
`shouldQParseTo`
QList [ QSplice "a"
, QUnquote "b"
, QSplice "c"
, QUnquote "d"
, QSplice "e"
]
it "even at the top level (will fail during resolution)" $
",@thing" `shouldQParseTo` QSplice "thing"
it "but not with a space between the \",\" and \"@\"" $
"(, @ thing)"
`shouldQParseTo`
QList [ QUnquote "@", QSymbol "thing" ]
resolveQuasiquoteSpec :: Spec
resolveQuasiquoteSpec = describe "resolveQuasiquote" $ do
let noBindings = ([], [])
let bindings = ( [ ("a", Number 1) ]
, [ ("xs", [ Number 2, Number 3 ])
, ("x1", [ Symbol "justOne" ])
, ("x0", [])
]
)
it "should expand a single symbol" $
resolveQuasiquote noBindings (QSymbol "x")
`shouldBe`
Right (Symbol "x")
it "should expand a single number" $
resolveQuasiquote noBindings (QNumber 20)
`shouldBe`
Right (Number 20)
it "should expand the empty list with no unquotes" $
resolveQuasiquote noBindings (QList [])
`shouldBe`
Right (List [])
it "should expand a singleton list with no unquotes" $
resolveQuasiquote noBindings (QList [ QNumber 10 ])
`shouldBe`
Right (List [ Number 10 ])
it "should expand a longer list with no unquotes" $
resolveQuasiquote noBindings (QList [ QNumber 10, QSymbol "z" ])
`shouldBe`
Right (List [ Number 10, Symbol "z" ])
describe "should expand unquote terms" $ do
it "at the top level" $ do
let input = QUnquote "a"
let result = resolveQuasiquote bindings input
result `shouldBe` Right (Number 1)
it "inside a list" $ do
let input = QList [ QNumber 0, QUnquote "a", QNumber 2 ]
let result = resolveQuasiquote bindings input
result `shouldBe` Right (List $ map Number [0, 1, 2])
describe "when expanding unquote-splicing terms" $ do
it "should succeed inside a list" $ do
let input = QList [ QNumber 1, QSplice "xs", QNumber 4 ]
let result = resolveQuasiquote bindings input
result `shouldBe` Right (List $ map Number [1, 2, 3, 4])
-- We include separate tests for splicing terms of different lengths
-- because one superficially reasonable implementation might just say,
-- "expand all the terms normally, then make sure we have exactly one;
-- if we don't, there was a top-level unquote-splicing term,
-- which is illegal."
-- This indeed properly handles well-formed quasiquoted expressions,
-- but does not account for the fact that
-- a quasiquoted expression at the top level
-- may contain exactly one term;
-- this is still an illegal expression and must be handled accordingly.
describe "should fail at the top level" $ do
it "with a term of length 0" $ shouldFail $
resolveQuasiquote bindings (QSplice "x0")
it "with a term of length 1" $ shouldFail $
resolveQuasiquote bindings (QSplice "x1")
it "with a term of length 2" $ shouldFail $
resolveQuasiquote bindings (QSplice "xs")
it "should fail on an unbound unquote binding" $
shouldFail $ resolveQuasiquote noBindings (QUnquote "a")
it "should fail on an unbound unquote-splicing binding" $
shouldFail $ resolveQuasiquote noBindings (QList [ QSplice "a" ])
it "should allow unused unquote and unquote-splicing bindings" $ do
let input = QList $ map QNumber [10, 11]
let result = resolveQuasiquote bindings input
result `shouldBe` Right (List $ map Number [10, 11])
quasiquoteErrorHandlingSpec :: Spec
quasiquoteErrorHandlingSpec = describe "error handling" $ do
describe "when you parse an s-expression with quasiquotation" $ do
let result = parseSexp ",things"
it "should fail" $ shouldFail result
let (Left msg) = result
it "should mention quasiquote" $
msg `shouldContain` "detected use of quasiquote"
it "should suggest using parseQexp" $
msg `shouldContain` "parseQexp"
describe "when you have a syntax error in quasiquotation" $ do
let result = parseQexp ([], []) ",,,"
it "should fail" $ shouldFail result
let (Left msg) = result
it "should have a parse error message" $
msg `shouldContain` "unexpected" -- expect the unexpected!
describe "when you have an error in the quasiquote resolution" $ do
let result = parseQexp ([], []) ",uh-oh"
it "should fail" $ shouldFail result
let (Left msg) = result
it "should have the resolution error message" $
msg `shouldContain` "uh-oh"
shouldFail :: (Show a, Show b) => Either a b -> Expectation
shouldFail input = input `shouldSatisfy` isLeft
where isLeft (Left _) = True
isLeft (Right _) = False
shouldParseTo :: String -> SExp -> Expectation
shouldParseTo input output = parseSexp input `shouldBe` (Right output)
shouldQParseTo :: String -> QExp -> Expectation
shouldQParseTo input output = parseQexpRaw input `shouldBe` (Right output)
shouldFailToParse :: String -> Expectation
shouldFailToParse = shouldFail . parseSexp
shouldFailToQParse :: String -> Expectation
shouldFailToQParse = shouldFail . parseQexpRaw
