3
\$\begingroup\$

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 (QExp to SExp) 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 expandQuasiquote and resolveQuasiquote seem reasonable? In particular, is there a different approach that would prevent (with a compile-time guarantee) the invariant violation listed in the Right _ -> Left block of resolveQuasiquote?
  • 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 castError to 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
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.